diff options
79 files changed, 2372 insertions, 1923 deletions
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 18ee408..d47af73 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -30,7 +30,7 @@ updated. You can automate this (if you have bash): - get a copy of [cabal-dependency-licenses][] -- run at the command line: `./license/generate > LICENSE` +- run at the command line: `runhaskell license-generator/generate.hs > LICENSE` [cabal-dependency-licenses]: https://github.com/jaspervdj/cabal-dependency-licenses diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index cac0aad..fde3d54 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -36,6 +36,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@natefaubion](https://github.com/natefaubion) (Nathan Faubion) My existing contributions and all future contributions until further notice are Copyright Nathan Faubion, 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). - [@nicodelpiano](https://github.com/nicodelpiano) (Nicolas Del Piano) My existing contributions and all future contributions until further notice are Copyright Nicolas Del Piano, 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). - [@nullobject](https://github.com/nullobject) (Josh Bassett) My existing contributions and all future contributions until further notice are Copyright Josh Bassett, 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). +- [@nwolverson](https://github.com/nwolverson) (Nicholas Wolverson) My existing contributions and all future contributions until further notice are Copyright Nicholas Wolverson, 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). - [@osa1](https://github.com/osa1) (Ömer Sinan Ağacan) - My existing contributions and all future contributions until further notice are Copyright Ömer Sinan Ağacan, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license. - [@paf31](https://github.com/paf31) (Phil Freeman) My existing contributions and all future contributions until further notice are Copyright Phil Freeman, 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). - [@paulyoung](https://github.com/paulyoung) (Paul Young) My existing contributions and all future contributions until further notice are Copyright Paul Young, 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). @@ -55,6 +56,8 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, 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). - [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, 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). <http://opensource.org/licenses/MIT>. +- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, 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). +- [@tfausak](https://github.com/tfausak) (Taylor Fausak) My existing contributions and all future contributions until further notice are Copyright Taylor Fausak, 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 @@ -31,6 +31,7 @@ PureScript uses the following Haskell library packages. Their license files foll array attoparsec base + base-compat binary blaze-builder bower-json @@ -50,7 +51,9 @@ PureScript uses the following Haskell library packages. Their license files foll monad-control mtl nats + old-locale optparse-applicative + parallel parsec pattern-arrows pretty @@ -63,6 +66,7 @@ PureScript uses the following Haskell library packages. Their license files foll split stm syb + tagged template-haskell terminfo text @@ -111,22 +115,22 @@ HUnit LICENSE file: HUnit is Copyright (c) Dean Herington, 2002, all rights reserved, and is distributed as free software under the following license. - + 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. - + - The names of the copyright holders may not be used to endorse or promote products derived from this software without specific prior written permission. - + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -142,24 +146,24 @@ HUnit LICENSE file: aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. - + 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 @@ -175,7 +179,7 @@ aeson LICENSE file: aeson-better-errors LICENSE file: Copyright (c) 2015 Harry Garrood - + 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 @@ -183,10 +187,10 @@ aeson-better-errors LICENSE file: 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. @@ -199,10 +203,10 @@ ansi-terminal 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 @@ -210,7 +214,7 @@ ansi-terminal LICENSE file: 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 @@ -223,19 +227,19 @@ ansi-terminal LICENSE file: ansi-wl-pprint LICENSE file: Copyright 2008, Daan Leijen and Max 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. - + This software is provided by the copyright holders "as is" and any express or implied warranties, including, but not limited to, the implied warranties of merchantability and fitness for a particular @@ -251,43 +255,43 @@ ansi-wl-pprint LICENSE file: array LICENSE file: This library (libraries/base) is derived from code from several - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + * Code from the Haskell Foreign Function Interface specification, which is (c) Manuel M. T. Chakravarty and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -300,14 +304,14 @@ array LICENSE file: 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. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -315,15 +319,15 @@ array LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + ----------------------------------------------------------------------------- - + Code derived from the document "The Haskell 98 Foreign Function Interface, An Addendum to the Haskell 98 Report" is distributed under the following license: - + Copyright (c) 2002 Manuel M. T. Chakravarty - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -331,30 +335,30 @@ array LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Foreign Function Interface. - + ----------------------------------------------------------------------------- attoparsec 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 @@ -370,43 +374,43 @@ attoparsec LICENSE file: base LICENSE file: This library (libraries/base) is derived from code from several - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + * Code from the Haskell Foreign Function Interface specification, which is (c) Manuel M. T. Chakravarty and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -419,14 +423,14 @@ base LICENSE file: 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. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -434,15 +438,15 @@ base LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + ----------------------------------------------------------------------------- - + Code derived from the document "The Haskell 98 Foreign Function Interface, An Addendum to the Haskell 98 Report" is distributed under the following license: - + Copyright (c) 2002 Manuel M. T. Chakravarty - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -450,30 +454,52 @@ base LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Foreign Function Interface. - + ----------------------------------------------------------------------------- +base-compat LICENSE file: + + Copyright (c) 2012-2015 Simon Hengel <sol@typeful.net> and Ryan Scott <ryan.gl.scott@ku.edu> + + 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. + binary 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 @@ -489,24 +515,24 @@ binary LICENSE file: blaze-builder LICENSE file: Copyright Jasper Van der Jeugt 2010, Simon Meier 2010 & 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 Jasper Van der Jeugt 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 @@ -522,7 +548,7 @@ blaze-builder LICENSE file: bower-json LICENSE file: Copyright (c) 2015 Harry Garrood - + 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 @@ -530,10 +556,10 @@ bower-json LICENSE file: 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. @@ -545,7 +571,7 @@ bower-json LICENSE file: boxes LICENSE file: Copyright (c) Brent Yorgey 2008 - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -557,9 +583,9 @@ boxes LICENSE file: 3. Neither the name of the author nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + All other rights are reserved. - + 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 @@ -578,9 +604,9 @@ bytestring LICENSE file: (c) Duncan Coutts 2006-2015 (c) David Roundy 2003-2005 (c) Simon Meier 2010-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: @@ -592,7 +618,7 @@ bytestring LICENSE file: 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 REGENTS 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 @@ -608,24 +634,24 @@ bytestring LICENSE file: containers LICENSE file: The Glasgow Haskell Compiler License - + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -644,28 +670,28 @@ deepseq LICENSE file: This library (deepseq) is derived from code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below). - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2001-2009, The University Court of the University of Glasgow. + + Copyright 2001-2009, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -678,45 +704,45 @@ deepseq LICENSE file: 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. - + ----------------------------------------------------------------------------- directory LICENSE file: This library (libraries/base) is derived from code from two - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. Both of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -729,14 +755,14 @@ directory LICENSE file: 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. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -744,31 +770,31 @@ directory LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + ----------------------------------------------------------------------------- dlist LICENSE file: Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather - + 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 Don Stewart 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 @@ -785,23 +811,23 @@ filepath LICENSE file: Copyright Neil Mitchell 2005-2015. 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 Neil Mitchell 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 @@ -817,39 +843,39 @@ filepath LICENSE file: ghc-prim LICENSE file: This library (libraries/ghc-prim) is derived from code from several - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. All of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -862,14 +888,14 @@ ghc-prim LICENSE file: 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. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -877,29 +903,29 @@ ghc-prim LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + hashable LICENSE file: Copyright Milan Straka 2010 - + 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 Milan Straka 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 @@ -916,17 +942,17 @@ haskeline LICENSE file: Copyright 2007-2009, Judah Jacobson. All Rights Reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistribution of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - + - Redistribution 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 AUTHOR 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 @@ -941,24 +967,24 @@ haskeline LICENSE file: integer-gmp LICENSE file: Copyright (c) 2014, Herbert Valerio Riedel - + 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 Herbert Valerio Riedel 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 @@ -974,24 +1000,24 @@ integer-gmp LICENSE file: language-javascript LICENSE file: Copyright (c)2010, Alan Zimmerman - + 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 Alan Zimmerman 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 @@ -1008,22 +1034,22 @@ lifted-base LICENSE file: Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg 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 the author 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 @@ -1040,22 +1066,22 @@ monad-control LICENSE file: Copyright © 2010, Bas van Dijk, Anders Kaseorg 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 the author 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 @@ -1071,24 +1097,24 @@ monad-control LICENSE file: mtl LICENSE file: The Glasgow Haskell Compiler License - + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1105,24 +1131,24 @@ mtl LICENSE file: nats 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. - + 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 @@ -1135,27 +1161,93 @@ nats LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +old-locale LICENSE file: + + This library (libraries/base) is derived from code from two + sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + The full text of these licenses is reproduced below. Both of the + licenses are BSD-style or compatible. + + ----------------------------------------------------------------------------- + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND 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 + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. + + ----------------------------------------------------------------------------- + + Code derived from the document "Report on the Programming Language + Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + + ----------------------------------------------------------------------------- + optparse-applicative LICENSE file: Copyright (c) 2012, Paolo Capriotti - + 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 Paolo Capriotti 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 @@ -1168,19 +1260,61 @@ optparse-applicative 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. +parallel LICENSE file: + + This library (libraries/parallel) is derived from code from + the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below). + + ----------------------------------------------------------------------------- + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND 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 + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. + + ----------------------------------------------------------------------------- + parsec LICENSE file: Copyright 1999-2000, Daan Leijen; 2007, Paolo Martini. 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 "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 @@ -1195,19 +1329,19 @@ parsec LICENSE file: pattern-arrows LICENSE file: The MIT License (MIT) - + Copyright (c) 2013 Phil Freeman - + 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 @@ -1220,28 +1354,28 @@ pretty LICENSE file: This library (libraries/pretty) is derived from code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below). - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1254,28 +1388,28 @@ pretty LICENSE file: 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 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1288,44 +1422,44 @@ primitive LICENSE file: 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. - + process LICENSE file: This library (libraries/process) is derived from code from two - sources: - + sources: + * Code from the GHC project which is largely (c) The University of Glasgow, and distributable under a BSD-style license (see below), - + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones and freely redistributable (but see the full license for restrictions). - + The full text of these licenses is reproduced below. Both of the licenses are BSD-style or compatible. - + ----------------------------------------------------------------------------- - + The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1338,14 +1472,14 @@ process LICENSE file: 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. - + ----------------------------------------------------------------------------- - + Code derived from the document "Report on the Programming Language Haskell 98", is distributed under the following license: - + Copyright (c) 2002 Simon Peyton Jones - + The authors intend this Report to belong to the entire Haskell community, and so we grant permission to copy and distribute it for any purpose, provided that it is reproduced in its entirety, @@ -1353,7 +1487,7 @@ process LICENSE file: copied and distributed for any purpose, provided that the modified version is clearly presented as such, and that it does not claim to be a definition of the Haskell 98 Language. - + ----------------------------------------------------------------------------- rts LICENSE file: @@ -1364,23 +1498,23 @@ safe LICENSE file: Copyright Neil Mitchell 2007-2015. 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 Neil Mitchell 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 @@ -1396,24 +1530,24 @@ safe LICENSE file: scientific LICENSE file: Copyright (c) 2013, Bas van Dijk - + 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 Bas van Dijk 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 @@ -1429,20 +1563,20 @@ scientific LICENSE file: semigroups 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 @@ -1458,9 +1592,9 @@ semigroups LICENSE file: split LICENSE file: Copyright (c) 2008 Brent Yorgey, Louis Wasserman - + All rights reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: @@ -1472,7 +1606,7 @@ split LICENSE file: 3. Neither the name of the author 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 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 @@ -1488,24 +1622,24 @@ split LICENSE file: stm LICENSE file: The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1521,112 +1655,145 @@ stm LICENSE file: syb LICENSE file: - This library (libraries/syb) is derived from code from several
- sources:
-
- * Code from the GHC project which is largely (c) The University of
- Glasgow, and distributable under a BSD-style license (see below),
-
- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
- and freely redistributable (but see the full license for
- restrictions).
-
- * Code from the Haskell Foreign Function Interface specification,
- which is (c) Manuel M. T. Chakravarty and freely redistributable
- (but see the full license for restrictions).
-
- The full text of these licenses is reproduced below. All of the
- licenses are BSD-style or compatible.
-
- -----------------------------------------------------------------------------
-
- The Glasgow Haskell Compiler License
-
- Copyright 2004, The University Court of the University of Glasgow.
- 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF
- GLASGOW AND 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
- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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.
-
- -----------------------------------------------------------------------------
-
- Code derived from the document "Report on the Programming Language
- Haskell 98", is distributed under the following license:
-
- Copyright (c) 2002 Simon Peyton Jones
-
- The authors intend this Report to belong to the entire Haskell
- community, and so we grant permission to copy and distribute it for
- any purpose, provided that it is reproduced in its entirety,
- including this Notice. Modified versions of this Report may also be
- copied and distributed for any purpose, provided that the modified
- version is clearly presented as such, and that it does not claim to
- be a definition of the Haskell 98 Language.
-
- -----------------------------------------------------------------------------
-
- Code derived from the document "The Haskell 98 Foreign Function
- Interface, An Addendum to the Haskell 98 Report" is distributed under
- the following license:
-
- Copyright (c) 2002 Manuel M. T. Chakravarty
-
- The authors intend this Report to belong to the entire Haskell
- community, and so we grant permission to copy and distribute it for
- any purpose, provided that it is reproduced in its entirety,
- including this Notice. Modified versions of this Report may also be
- copied and distributed for any purpose, provided that the modified
- version is clearly presented as such, and that it does not claim to
- be a definition of the Haskell 98 Foreign Function Interface.
-
- -----------------------------------------------------------------------------
+ This library (libraries/syb) is derived from code from several + sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + * Code from the Haskell Foreign Function Interface specification, + which is (c) Manuel M. T. Chakravarty and freely redistributable + (but see the full license for restrictions). + + The full text of these licenses is reproduced below. All of the + licenses are BSD-style or compatible. + + ----------------------------------------------------------------------------- + + The Glasgow Haskell Compiler License + + Copyright 2004, The University Court of the University of Glasgow. + 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF + GLASGOW AND 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 + UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. + + ----------------------------------------------------------------------------- + + Code derived from the document "Report on the Programming Language + Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + + ----------------------------------------------------------------------------- + + Code derived from the document "The Haskell 98 Foreign Function + Interface, An Addendum to the Haskell 98 Report" is distributed under + the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + + ----------------------------------------------------------------------------- + +tagged LICENSE file: + + Copyright (c) 2009-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: + + * 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. template-haskell LICENSE file: - + The Glasgow Haskell Compiler License - + Copyright 2002-2007, The University Court of the University of Glasgow. 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1639,23 +1806,23 @@ template-haskell LICENSE file: 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. All Rights Reserved. - + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - + - Redistribution of source code must retain the above copyright notice, this list of conditions and the following disclamer. - + - Redistribution in binary form must reproduce the above copyright notice, this list of conditions and the following disclamer in the documentation and/or other materials provided with the distribution. - + THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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 @@ -1671,19 +1838,19 @@ text LICENSE file: Copyright (c) 2008-2009, Tom Harper 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 @@ -1700,36 +1867,36 @@ time LICENSE file: TimeLib is Copyright (c) Ashley Yakeley, 2004-2014. All rights reserved. Certain sections are Copyright 2004, The University Court of the University of Glasgow. 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. - + - Neither name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. - + 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. transformers LICENSE file: The Glasgow Haskell Compiler License - + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1747,19 +1914,19 @@ transformers-base LICENSE file: Copyright (c) 2011, Mikhail Vorozhtsov, Bas van Dijk All rights reserved. - - Redistribution and use in source and binary forms, with or without + + 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, + + - 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 + - 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 names of the copyright owners nor the names of the - contributors may be used to endorse or promote products derived + - Neither the names of the copyright owners nor the names of the + 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 @@ -1771,29 +1938,29 @@ transformers-base LICENSE file: 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. - + transformers-compat LICENSE file: Copyright 2012 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 @@ -1809,24 +1976,24 @@ transformers-compat LICENSE file: unix LICENSE file: The Glasgow Haskell Compiler License - - Copyright 2004, The University Court of the University of Glasgow. + + Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1843,24 +2010,24 @@ unix LICENSE file: unordered-containers LICENSE file: Copyright (c) 2010, Johan Tibell - + 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 Johan Tibell 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 @@ -1904,21 +2071,21 @@ vector LICENSE file: Copyright (c) 2008-2012, Roman Leshchinskiy 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without - specific prior written permission. - + specific prior written permission. + THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND @@ -1931,29 +2098,29 @@ vector LICENSE file: 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. - + void LICENSE file: Copyright 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 @@ -26,3 +26,4 @@ A small strongly typed programming language with expressive types that compiles - [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript) - [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript) - [Google Group](https://groups.google.com/forum/#!forum/purescript) +- [Gitter Channel](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) diff --git a/examples/failing/1175.purs b/examples/failing/1175.purs new file mode 100644 index 0000000..13f1f70 --- /dev/null +++ b/examples/failing/1175.purs @@ -0,0 +1,11 @@ +-- @shouldFailWith TypesDoNotUnify +module X where + +class Foo where + foo :: String + +instance f :: Foo where + foo = "a" + where + bar :: String + bar = 1 diff --git a/examples/passing/1335.purs b/examples/passing/1335.purs new file mode 100644 index 0000000..e2a7347 --- /dev/null +++ b/examples/passing/1335.purs @@ -0,0 +1,12 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +x :: forall a. a -> String +x a = y "Done" + where + y :: forall a. (Show a) => a -> String + y a = show (a :: a) + +main = log (x 0) diff --git a/examples/passing/FieldConsPuns.purs b/examples/passing/FieldConsPuns.purs new file mode 100644 index 0000000..9a775e0 --- /dev/null +++ b/examples/passing/FieldConsPuns.purs @@ -0,0 +1,10 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = greet { greeting, name} where + greeting = "Hello" + name = "World" diff --git a/examples/passing/FieldPuns.purs b/examples/passing/FieldPuns.purs new file mode 100644 index 0000000..d30444a --- /dev/null +++ b/examples/passing/FieldPuns.purs @@ -0,0 +1,8 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console + +greet { greeting, name } = log $ greeting <> ", " <> name <> "." + +main = greet { greeting: "Hello", name: "World" } diff --git a/examples/passing/OperatorSections.purs b/examples/passing/OperatorSections.purs index a9c426c..0143d34 100644 --- a/examples/passing/OperatorSections.purs +++ b/examples/passing/OperatorSections.purs @@ -8,4 +8,10 @@ main = do assert $ (2.0 /) 4.0 == 0.5 assert $ (`const` 1.0) 2.0 == 2.0 assert $ (1.0 `const`) 2.0 == 1.0 + let foo = { x: 2.0 } + assert $ (/ foo.x) 4.0 == 2.0 + assert $ (foo.x /) 4.0 == 0.5 + let (//) x y = x.x / y.x + assert $ (// foo { x = 4.0 }) { x: 4.0 } == 1.0 + assert $ (foo { x = 4.0 } //) { x: 4.0 } == 1.0 Control.Monad.Eff.Console.log "Done!" diff --git a/examples/passing/StringEscapes.purs b/examples/passing/StringEscapes.purs new file mode 100644 index 0000000..2d97744 --- /dev/null +++ b/examples/passing/StringEscapes.purs @@ -0,0 +1,15 @@ +module Main where + +import Prelude ((==), bind) +import Test.Assert (assert) + +singleCharacter = "\0\b\t\n\v\f\r\"\\" == "\x0\x8\x9\xA\xB\xC\xD\x22\x5C" +hex = "\x1D306\x2603\x3C6\xE0\x0" == "𝌆☃φà\0" +decimal = "\119558\9731\966\224\0" == "𝌆☃φà\0" +surrogatePair = "\xD834\xDF06" == "\x1D306" + +main = do + assert singleCharacter + assert hex + assert decimal + assert surrogatePair diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index 5b66605..819c87a 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -12,7 +12,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -48,20 +47,21 @@ data Options = Options , optionsEntryPoints :: [String] , optionsMainModule :: Maybe String , optionsNamespace :: String + , optionsRequirePath :: Maybe FilePath } deriving Show -- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier. guessModuleIdentifier :: (Applicative m, MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier -guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> (guessModuleType (takeFileName filename)) +guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename) where guessModuleType "index.js" = pure Regular - guessModuleType "foreign.js" = pure Foreign + guessModuleType "foreign.js" = pure Foreign guessModuleType name = throwError $ UnsupportedModulePath name -- | 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 :: forall m. (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String +app :: (Applicative m, MonadError ErrorMessage m, MonadIO m) => Options -> m String app Options{..} = do inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles when (null inputFiles) . liftIO $ do @@ -71,11 +71,11 @@ app Options{..} = do js <- liftIO (readFile filename) mid <- guessModuleIdentifier filename return (mid, js) - - let entryIds = (map (`ModuleIdentifier` Regular) optionsEntryPoints) - bundle input entryIds optionsMainModule optionsNamespace - + let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints + + bundle input entryIds optionsMainModule optionsNamespace optionsRequirePath + -- | Command line options parser. options :: Parser Options options = Options <$> some inputFile @@ -83,29 +83,30 @@ options = Options <$> some inputFile <*> many entryPoint <*> optional mainModule <*> namespace - where + <*> optional requirePath + where inputFile :: Parser FilePath inputFile = strArgument $ metavar "FILE" <> help "The input .js file(s)" - + outputFile :: Parser FilePath outputFile = strOption $ short 'o' <> long "output" <> help "The output .js file" - + entryPoint :: Parser String entryPoint = strOption $ short 'm' <> long "module" <> help "Entry point module name(s). All code which is not a transitive dependency of an entry point module will be removed." - + mainModule :: Parser String mainModule = strOption $ long "main" <> help "Generate code to run the main method in the specified module." - + namespace :: Parser String namespace = strOption $ short 'n' @@ -113,8 +114,15 @@ options = Options <$> some inputFile <> Opts.value "PS" <> showDefault <> help "Specify the namespace that PureScript modules will be exported to when running in the browser." - --- | Make it go. + + requirePath :: Parser FilePath + requirePath = strOption $ + short 'r' + <> long "require-path" + <> Opts.value "" + <> help "The path prefix used in require() calls in the generated JavaScript" + +-- | Make it go. main :: IO () main = do opts <- execParser (info (version <*> helper <*> options) infoModList) diff --git a/psc-docs/Ctags.hs b/psc-docs/Ctags.hs index 3635534..d5018ea 100644 --- a/psc-docs/Ctags.hs +++ b/psc-docs/Ctags.hs @@ -5,7 +5,7 @@ import Tags import Data.List (sort) dumpCtags :: [(String, P.Module)] -> [String] -dumpCtags = sort . concat . (map renderModCtags) +dumpCtags = sort . concatMap renderModCtags renderModCtags :: (String, P.Module) -> [String] renderModCtags (path, mdl) = sort tagLines diff --git a/psc-docs/Etags.hs b/psc-docs/Etags.hs index cb3c98c..5aec45d 100644 --- a/psc-docs/Etags.hs +++ b/psc-docs/Etags.hs @@ -4,12 +4,10 @@ import qualified Language.PureScript as P import Tags dumpEtags :: [(String, P.Module)] -> [String] -dumpEtags = concat . (map renderModEtags) +dumpEtags = concatMap renderModEtags renderModEtags :: (String, P.Module) -> [String] renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines where tagsLen = sum $ map length tagLines tagLines = map tagLine $ tags mdl tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ "," - - diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index d691d2a..912f460 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -9,12 +9,20 @@ import Options.Applicative hiding (str) import qualified Paths_purescript as Paths import Language.PureScript.Publish +import Language.PureScript.Publish.ErrorsWarnings dryRun :: Parser Bool dryRun = switch $ long "dry-run" <> help "Produce no output, and don't require a tagged version to be checked out." +dryRunOptions :: PublishOptions +dryRunOptions = defaultPublishOptions + { publishGetVersion = return dummyVersion + , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn + } + where dummyVersion = ("0.0.0", Version [0,0,0] []) + main :: IO () main = execParser opts >>= publish where @@ -30,8 +38,7 @@ publish :: Bool -> IO () publish isDryRun = if isDryRun then do - let dummyVersion = ("0.0.0", Version [0,0,0] []) - _ <- preparePackage $ defaultPublishOptions { publishGetVersion = return dummyVersion } + _ <- preparePackage dryRunOptions putStrLn "Dry run completed, no errors." else do pkg <- preparePackage defaultPublishOptions diff --git a/psci/Completion.hs b/psci/Completion.hs index 3565275..8a52463 100644 --- a/psci/Completion.hs +++ b/psci/Completion.hs @@ -1,19 +1,14 @@ -{-# LANGUAGE CPP #-} - module Completion where +import Prelude () +import Prelude.Compat + import Data.Maybe (mapMaybe) import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix) import Data.Char (isUpper) import Data.Function (on) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif import Control.Arrow (second) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>)) -#endif import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT) import Control.Monad.Trans.State.Strict @@ -177,12 +172,8 @@ getAllQualifications sho m (declName, decl) = do let q = qualifyWith asQ' in case importType of P.Implicit -> [q] - P.Explicit refs -> if referencedBy refs - then [q] - else [] - P.Hiding refs -> if referencedBy refs - then [] - else [q] + P.Explicit refs -> [q | referencedBy refs] + P.Hiding refs -> [q | not $ referencedBy refs] -- | Returns all the ImportedModule values referring to imports of a particular diff --git a/psci/PSCi.hs b/psci/PSCi.hs index 0912c04..d75ccee 100644 --- a/psci/PSCi.hs +++ b/psci/PSCi.hs @@ -17,30 +17,28 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} module PSCi where +import Prelude () +import Prelude.Compat + import Data.Foldable (traverse_) -import Data.List (intercalate, nub, sort) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif +import Data.Maybe (mapMaybe) +import Data.List (intersperse, intercalate, nub, sort) import Data.Tuple (swap) import Data.Version (showVersion) import qualified Data.Map as M -import Control.Applicative import Control.Arrow (first) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Class -import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Except (ExceptT(), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.Trans.State.Strict import Control.Monad.IO.Class (liftIO) -import Control.Monad.Writer.Strict (runWriter) -import qualified Control.Monad.Trans.State.Lazy as L +import Control.Monad.Writer.Strict (Writer(), runWriter) import Options.Applicative as Opts @@ -51,6 +49,7 @@ import System.FilePath (pathSeparator, (</>), isPathSeparator) import System.FilePath.Glob (glob) import System.Process (readProcessWithExitCode) import System.IO.Error (tryIOError) +import qualified Text.PrettyPrint.Boxes as Box import qualified Language.PureScript as P import qualified Language.PureScript.Names as N @@ -254,7 +253,7 @@ modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" -- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the -- options and ignores the warning messages. runMake :: P.Make a -> IO (Either P.MultipleErrors a) -runMake mk = fmap fst $ P.runMake P.defaultOptions mk +runMake mk = fst <$> P.runMake P.defaultOptions mk makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a makeIO f io = do @@ -377,20 +376,104 @@ handleTypeOf val = do -- Pretty print a module's signatures -- printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI () -printModuleSignatures moduleName env = - PSCI $ let namesEnv = P.names env - moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv - in case moduleNamesIdent of - [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions." - _ -> ( outputStrLn - . unlines - . sort - . map (showType . findType namesEnv)) moduleNamesIdent - where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) - findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) - showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String - showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType - showType _ = P.internalError "The impossible happened in printModuleSignatures." +printModuleSignatures moduleName (P.Environment {..}) = + PSCI $ + -- get relevant components of a module from environment + let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names + moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses + moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types + + in + -- print each component + (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left) + [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses + , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types + , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions + ] + + where printModule's showF = Box.vsep 1 Box.left . showF + + findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) + findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames) + + showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box + showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType + showNameType _ = P.internalError "The impossible happened in printModuleSignatures." + + findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) + findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) + + showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box + showTypeClass (_, Nothing) = Nothing + showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) = + let constraints = + if null constrs + then Box.text "" + else Box.text "(" + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs) + Box.<> Box.text ") <= " + className = + Box.text (P.runProperName name) + Box.<> Box.text (concatMap ((' ':) . fst) vars) + classBody = + Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body) + + in + Just $ + (Box.text "class " + Box.<> constraints + Box.<> className + Box.<+> if null body then Box.text "" else Box.text "where") + Box.// Box.moveRight 2 classBody + + + findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind)) + findType envTypes name = (name, M.lookup name envTypes) + + showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) + -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident]) + -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type) + -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind)) + -> Maybe Box.Box + showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = + case (typ, M.lookup n typeSynonymsEnv) of + (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> + if M.member n typeClassesEnv + then + Nothing + else + Just $ + Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) + Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType) + + (Just (_, P.DataType typevars pt), _) -> + let prefix = + case pt of + [(dtProperName,_)] -> + case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of + Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType + _ -> "data" + _ -> "data" + + in + Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt + + _ -> + Nothing + + where printCons pt = + Box.moveRight 2 $ + Box.vcat Box.left $ + mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $ + map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt + + prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t + + mapFirstRest _ _ [] = [] + mapFirstRest f g (x:xs) = f x : map g xs + + trimEnd = reverse . dropWhile (== ' ') . reverse + -- | -- Browse a module and displays its signature (if module exists). @@ -424,8 +507,11 @@ handleKindOf typ = do Right env' -> case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do - let chk = P.CheckState env' 0 0 (Just mName) - k = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf typ')) chk + let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } + k = check (P.kindOf typ') chk + + check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState) + check sew cs = fst . runWriter . runExceptT . runStateT sew $ cs case k of Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind @@ -442,8 +528,8 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do case firstLine of Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty Just "" -> return (Right Nothing) - Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s - Just s -> either Left (Right . Just) . parseCommand <$> go [s] + Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s + Just s -> fmap Just . parseCommand <$> go [s] where go :: [String] -> InputT (StateT PSCiState IO) String go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " " @@ -507,7 +593,7 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters if exists then do ls <- lines <$> readFile configFile - case mapM parseCommand ls of + case traverse parseCommand ls of Left err -> print err >> exitFailure Right cs -> return $ Just cs else @@ -524,8 +610,8 @@ consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do config <- loadUserConfig - inputFiles <- concat <$> mapM glob psciInputFile - foreignFiles <- concat <$> mapM glob psciForeignInputFiles + inputFiles <- concat <$> traverse glob psciInputFile + foreignFiles <- concat <$> traverse glob psciForeignInputFiles modulesOrFirstError <- loadAllModules inputFiles case modulesOrFirstError of Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure @@ -540,7 +626,7 @@ loop PSCiOptions{..} = do Right foreigns -> flip evalStateT (PSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do outputStrLn prologueMessage - traverse_ (mapM_ (runPSCI . handleCommand)) config + traverse_ (traverse_ (runPSCI . handleCommand)) config modules' <- lift $ gets psciLoadedModules unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines [ "PSCi requires the purescript-console module to be installed." diff --git a/psci/Parser.hs b/psci/Parser.hs index d4a3a2d..cb00db1 100644 --- a/psci/Parser.hs +++ b/psci/Parser.hs @@ -13,21 +13,16 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Parser ( parseCommand ) where -import Prelude hiding (lex) +import Prelude () +import Prelude.Compat hiding (lex) import Data.Char (isSpace) import Data.List (intercalate) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative hiding (many) -#endif - import Text.Parsec hiding ((<|>)) import qualified Language.PureScript as P diff --git a/psci/tests/Main.hs b/psci/tests/Main.hs index bc4af94..d3d6d3b 100644 --- a/psci/tests/Main.hs +++ b/psci/tests/Main.hs @@ -1,14 +1,13 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} module Main where +import Prelude () +import Prelude.Compat + import Control.Monad.Trans.State.Strict (runStateT) import Control.Monad (when, forM) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Writer.Strict (runWriterT) import Control.Monad.Trans.Except (runExceptT) diff --git a/purescript.cabal b/purescript.cabal index bfeafe8..65b733a 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.7.5.4 +version: 0.7.6.1 cabal-version: >=1.8 build-type: Simple license: MIT @@ -40,6 +40,7 @@ source-repository head library build-depends: base >=4.6 && <5, + base-compat >=0.6.0, lifted-base >= 0.2.3 && < 0.2.4, monad-control >= 1.0.0.0 && < 1.1, transformers-base >= 0.4.0 && < 0.5, @@ -68,7 +69,8 @@ library Glob >= 0.7 && < 0.8, process >= 1.2.0 && < 1.4, safe >= 0.3.9 && < 0.4, - semigroups >= 0.16.2 && < 0.19 + semigroups >= 0.16.2 && < 0.19, + parallel >= 3.2 && < 3.3 exposed-modules: Language.PureScript Language.PureScript.AST @@ -108,6 +110,7 @@ library Language.PureScript.Kinds Language.PureScript.Linter Language.PureScript.Linter.Exhaustive + Language.PureScript.Linter.Imports Language.PureScript.Make Language.PureScript.ModuleDependencies Language.PureScript.Names @@ -171,7 +174,6 @@ library Language.PureScript.Publish.BoxesHelpers Control.Monad.Logger - Control.Monad.Unify Control.Monad.Supply Control.Monad.Supply.Class @@ -195,7 +197,8 @@ executable psci build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, optparse-applicative >= 0.10.0, parsec -any, haskeline >= 0.7.0.0, purescript -any, transformers -any, - transformers-compat -any, process -any, time -any, Glob -any + transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0, + boxes >= 0.1.4 && < 0.2.0 main-is: Main.hs buildable: True @@ -258,7 +261,7 @@ test-suite tests build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, parsec -any, purescript -any, transformers -any, process -any, transformers-compat -any, time -any, - Glob -any + Glob -any, base-compat >=0.6.0 type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TestsSetup @@ -270,7 +273,7 @@ test-suite psci-tests mtl -any, optparse-applicative >= 0.10.0, parsec -any, haskeline >= 0.7.0.0, purescript -any, transformers -any, transformers-compat -any, process -any, HUnit -any, time -any, - Glob -any + Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0 type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TestsSetup diff --git a/src/Control/Monad/Logger.hs b/src/Control/Monad/Logger.hs index 4d8ab2f..069b781 100644 --- a/src/Control/Monad/Logger.hs +++ b/src/Control/Monad/Logger.hs @@ -12,19 +12,17 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Control.Monad.Logger where +import Prelude () +import Prelude.Compat + import Data.IORef -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -import Control.Applicative -#endif import Control.Monad (ap) import Control.Monad.IO.Class import Control.Monad.Writer.Class diff --git a/src/Control/Monad/Supply.hs b/src/Control/Monad/Supply.hs index ef08980..1ae1e72 100644 --- a/src/Control/Monad/Supply.hs +++ b/src/Control/Monad/Supply.hs @@ -14,15 +14,14 @@ ----------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} module Control.Monad.Supply where +import Prelude () +import Prelude.Compat + import Data.Functor.Identity -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Reader diff --git a/src/Control/Monad/Unify.hs b/src/Control/Monad/Unify.hs deleted file mode 100644 index 53db603..0000000 --- a/src/Control/Monad/Unify.hs +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Control.Monad.Unify --- Copyright : (c) Phil Freeman 2013 --- License : MIT --- --- Maintainer : Phil Freeman <paf31@cantab.net> --- Stability : experimental --- Portability : --- --- | --- --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.Monad.Unify where - -import Data.Monoid - -import Control.Applicative -import Control.Monad.State -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (MonadWriter(..)) - -import Data.HashMap.Strict as M - --- | --- Untyped unification variables --- -type Unknown = Int - --- | --- A type which can contain unification variables --- -class Partial t where - unknown :: Unknown -> t - isUnknown :: t -> Maybe Unknown - unknowns :: t -> [Unknown] - ($?) :: Substitution t -> t -> t - --- | --- Identifies types which support unification --- -class (Partial t) => Unifiable m t | t -> m where - (=?=) :: t -> t -> UnifyT t m () - --- | --- A substitution maintains a mapping from unification variables to their values --- -data Substitution t = Substitution { runSubstitution :: M.HashMap Int t } - -instance (Partial t) => Monoid (Substitution t) where - mempty = Substitution M.empty - s1 `mappend` s2 = Substitution $ - M.map (s2 $?) (runSubstitution s1) `M.union` - M.map (s1 $?) (runSubstitution s2) - --- | --- State required for type checking --- -data UnifyState t = UnifyState { - -- | - -- The next fresh unification variable - -- - unifyNextVar :: Int - -- | - -- The current substitution - -- - , unifyCurrentSubstitution :: Substitution t - } - --- | --- An empty @UnifyState@ --- -defaultUnifyState :: (Partial t) => UnifyState t -defaultUnifyState = UnifyState 0 mempty - --- | --- A class for errors which support unification errors --- -class UnificationError t e where - occursCheckFailed :: t -> e - --- | --- The type checking monad, which provides the state of the type checker, and error reporting capabilities --- -newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a } - deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadWriter w) - -instance (MonadState s m) => MonadState s (UnifyT t m) where - get = UnifyT . lift $ get - put = UnifyT . lift . put - -instance (MonadError e m) => MonadError e (UnifyT t m) where - throwError = UnifyT . throwError - catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f) - --- | --- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable --- -runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t) -runUnify s = flip runStateT s . unUnify - --- | --- Substitute a single unification variable --- -substituteOne :: (Partial t) => Unknown -> t -> Substitution t -substituteOne u t = Substitution $ M.singleton u t - --- | --- Replace a unification variable with the specified value in the current substitution --- -(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m () -(=:=) u t' = do - st <- UnifyT get - let sub = unifyCurrentSubstitution st - let t = sub $? t' - occursCheck u t - let current = sub $? unknown u - case isUnknown current of - Just u1 | u1 == u -> return () - _ -> current =?= t - UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s } - --- | --- Perform the occurs check, to make sure a unification variable does not occur inside a value --- -occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m () -occursCheck u t = - case isUnknown t of - Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t - _ -> return () - --- | --- Generate a fresh untyped unification variable --- -fresh' :: (Monad m) => UnifyT t m Unknown -fresh' = do - st <- UnifyT get - UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) } - return $ unifyNextVar st - --- | --- Generate a fresh unification variable at a specific type --- -fresh :: (Monad m, Partial t) => UnifyT t m t -fresh = do - u <- fresh' - return $ unknown u - - - diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 06812a2..ea6b195 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -15,7 +15,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 7c8f915..07ff4b1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -15,10 +15,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Language.PureScript.AST.Declarations where +import Prelude () +import Prelude.Compat + import Data.Aeson.TH import qualified Data.Data as D @@ -26,10 +28,6 @@ import qualified Data.Map as M import Control.Monad.Identity -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - import Language.PureScript.AST.Binders import Language.PureScript.AST.Operators import Language.PureScript.AST.SourcePos diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index e1d8fc5..10fd8c9 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -12,7 +12,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} @@ -20,14 +19,13 @@ module Language.PureScript.AST.SourcePos where +import Prelude () +import Prelude.Compat + import qualified Data.Data as D import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif - -- | -- Source position information -- diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 1d97ebc..3378a6c 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -12,21 +12,12 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.AST.Traversals where -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (Monoid(..), mconcat) -#endif -import Data.Maybe (mapMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif +import Prelude () +import Prelude.Compat -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Data.Maybe (mapMaybe) import Control.Monad import Control.Arrow ((***), (+++), second) @@ -101,10 +92,10 @@ everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) => (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) where - f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds - f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val - f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds - f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds + f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds + f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds + f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f' <=< f) ds f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f') f' other = f other @@ -114,37 +105,37 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h) g' (Parens v) = Parens <$> (g v >>= g') g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g')) g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g')) - g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs - g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs - g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs + g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs + g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs + g' (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g' <=< g)) vs g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g') g' (Accessor prop v) = Accessor prop <$> (g v >>= g') - g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs - g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> mapM (sndM $ maybeM (g' <=< g)) vs + g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs + g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> traverse (sndM $ maybeM (g' <=< g)) vs g' (Abs name v) = Abs name <$> (g v >>= g') g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g') g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g') - g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts + g' (Case vs alts) = Case <$> traverse (g' <=< g) vs <*> traverse handleCaseAlternative alts g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty - g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g') - g' (Do es) = Do <$> mapM handleDoNotationElement es + g' (Let ds v) = Let <$> traverse (f' <=< f) ds <*> (g v >>= g') + g' (Do es) = Do <$> traverse handleDoNotationElement es g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g') g' other = g other - h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs - h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs - h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs + h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs + h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs + h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h') h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h') h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h') h' other = h other - handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs - <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val + handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs + <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v - handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds + handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e everywhereOnValuesM :: (Functor m, Applicative m, Monad m) => @@ -154,11 +145,11 @@ everywhereOnValuesM :: (Functor m, Applicative m, Monad m) => (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder) everywhereOnValuesM f g h = (f', g', h') where - f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f - f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f - f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f - f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f - f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM f') ds) >>= f + f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f + f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f + f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f + f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> traverse f' ds) >>= f + f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f f' other = f other @@ -167,37 +158,37 @@ everywhereOnValuesM f g h = (f', g', h') g' (Parens v) = (Parens <$> g' v) >>= g g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g - g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g - g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g - g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g + g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g + g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g + g' (ObjectConstructor vs) = (ObjectConstructor <$> traverse (sndM $ maybeM g') vs) >>= g g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g - g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g - g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> mapM (sndM $ maybeM g') vs) >>= g + g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g + g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> traverse (sndM $ maybeM g') vs) >>= g g' (Abs name v) = (Abs name <$> g' v) >>= g g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g - g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g + g' (Case vs alts) = (Case <$> traverse g' vs <*> traverse handleCaseAlternative alts) >>= g g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g - g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g - g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g + g' (Let ds v) = (Let <$> traverse f' ds <*> g' v) >>= g + g' (Do es) = (Do <$> traverse handleDoNotationElement es) >>= g g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g g' other = g other - h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h - h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h - h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h + h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h + h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h + h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h h' other = h other - handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs - <*> eitherM (mapM (pairM g' g')) g' val + handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs + <*> eitherM (traverse (pairM g' g')) g' val handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v - handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds + handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e everythingOnValues :: (r -> r -> r) -> @@ -345,11 +336,11 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j where f'' s = uncurry f' <=< f s - f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds - f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val - f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds - f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds - f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM (f'' s)) ds + f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds + f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val + f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds + f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> traverse (f'' s) ds + f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1 f' _ other = return other @@ -360,28 +351,28 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j g' s (Parens v) = Parens <$> g'' s v g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v) g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v) - g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs - g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs - g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs + g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs + g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs + g' s (ObjectConstructor vs) = ObjectConstructor <$> traverse (sndM $ maybeM (g'' s)) vs g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v g' s (Accessor prop v) = Accessor prop <$> g'' s v - g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs - g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> mapM (sndM $ maybeM (g'' s)) vs + g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs + g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> traverse (sndM $ maybeM (g'' s)) vs g' s (Abs name v) = Abs name <$> g'' s v g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3 - g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts + g' s (Case vs alts) = Case <$> traverse (g'' s) vs <*> traverse (i'' s) alts g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty - g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v - g' s (Do es) = Do <$> mapM (j'' s) es + g' s (Let ds v) = Let <$> traverse (f'' s) ds <*> g'' s v + g' s (Do es) = Do <$> traverse (j'' s) es g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v g' _ other = return other h'' s = uncurry h' <=< h s - h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs - h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs - h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs + h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs + h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs + h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs h' s (NamedBinder name b) = NamedBinder name <$> h'' s b h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b h' s (TypedBinder t b) = TypedBinder t <$> h'' s b @@ -389,13 +380,13 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j i'' s = uncurry i' <=< i s - i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val + i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val j'' s = uncurry j' <=< j s j' s (DoNotationValue v) = DoNotationValue <$> g'' s v j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v - j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds + j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1 accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r) diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 64f7cc2..cee556f 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -19,8 +19,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Bundle ( bundle @@ -31,17 +29,17 @@ module Language.PureScript.Bundle ( , printErrorMessage ) where -import Data.List (nub) -import Data.Maybe (mapMaybe, catMaybes) +import Prelude () +import Prelude.Compat + +import Data.List (nub, stripPrefix) +import Data.Maybe (mapMaybe, catMaybes, fromMaybe) import Data.Generics (everything, everywhere, mkQ, mkT) import Data.Graph import Data.Version (showVersion) import qualified Data.Set as S -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.Error.Class import Language.JavaScript.Parser @@ -139,12 +137,13 @@ node (NN n) = n node (NT n _ _) = n -- | Calculate the ModuleIdentifier which a require(...) statement imports. -checkImportPath :: String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier -checkImportPath "./foreign" m _ = +checkImportPath :: Maybe FilePath -> String -> ModuleIdentifier -> S.Set String -> Maybe ModuleIdentifier +checkImportPath _ "./foreign" m _ = Just (ModuleIdentifier (moduleName m) Foreign) -checkImportPath name _ names - | name `S.member` names = Just (ModuleIdentifier name Regular) -checkImportPath _ _ _ = Nothing +checkImportPath requirePath name _ names + | Just name' <- stripPrefix (fromMaybe "" requirePath) name + , name' `S.member` names = Just (ModuleIdentifier name' Regular) +checkImportPath _ _ _ _ = Nothing -- | Compute the dependencies of all elements in a module, and add them to the tree. -- @@ -210,9 +209,9 @@ withDeps (Module modulePath es) = Module modulePath (map expandDeps es) -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. -toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSNode -> m Module -toModule mids mid top - | JSSourceElementsTop ns <- node top = Module mid <$> mapM toModuleElement ns +toModule :: forall m. (Applicative m, MonadError ErrorMessage m) => Maybe FilePath -> S.Set String -> ModuleIdentifier -> JSNode -> m Module +toModule requirePath mids mid top + | JSSourceElementsTop ns <- node top = Module mid <$> traverse toModuleElement ns | otherwise = err InvalidTopLevel where err = throwError . ErrorInModule mid @@ -227,7 +226,7 @@ toModule mids mid top , JSIdentifier "require" <- node req , JSArguments _ [ impS ] _ <- node impP , JSStringLiteral _ importPath <- node impS - , Just importPath' <- checkImportPath importPath mid mids + , Just importPath' <- checkImportPath requirePath importPath mid mids = pure (Require n importName importPath') toModuleElement n | JSVariables var [ varIntro ] _ <- node n @@ -262,7 +261,7 @@ toModule mids mid top , JSOperator eq <- node op , JSLiteral "=" <- node eq , JSObjectLiteral _ props _ <- node obj - = ExportsList <$> mapM toExport (filter (not . isSeparator) (map node props)) + = ExportsList <$> traverse toExport (filter (not . isSeparator) (map node props)) where toExport :: Node -> m (ExportType, String, JSNode, [Key]) toExport (JSPropertyNameandValue name _ [val] ) = @@ -531,20 +530,21 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (NN (JSSourceElem -- | The bundling function. -- This function performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -bundle :: forall m. (Applicative m, MonadError ErrorMessage m) +bundle :: (Applicative m, 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). + -> Maybe FilePath -- ^ The require path prefix -> m String -bundle inputStrs entryPoints mainModule namespace = do +bundle inputStrs entryPoints mainModule namespace requirePath = do input <- forM inputStrs $ \(ident, js) -> do ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) return (ident, ast) let mids = S.fromList (map (moduleName . fst) input) - modules <- mapM (fmap withDeps . uncurry (toModule mids)) input + modules <- traverse (fmap withDeps . uncurry (toModule requirePath mids)) input let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 3916a94..e409330 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -17,7 +17,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.CodeGen.JS ( module AST @@ -26,13 +25,13 @@ module Language.PureScript.CodeGen.JS , mainCall ) where +import Prelude () +import Prelude.Compat + import Data.List ((\\), delete, intersect) import Data.Maybe (isNothing) import qualified Data.Traversable as T (traverse) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow ((&&&)) import Control.Monad (replicateM, forM) import Control.Monad.Reader (MonadReader, asks) diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 90be974..a5ec412 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -14,18 +14,14 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} module Language.PureScript.CodeGen.JS.AST where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative, (<$>), (<*>)) -#endif +import Prelude () +import Prelude.Compat + import Control.Monad.Identity import Data.Data -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif import Language.PureScript.Comments import Language.PureScript.Traversals diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer.hs b/src/Language/PureScript/CodeGen/JS/Optimizer.hs index 9d2e2ab..5e2a38e 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer.hs @@ -32,15 +32,14 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} module Language.PureScript.CodeGen.JS.Optimizer ( optimize ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative) -#endif +import Prelude () +import Prelude.Compat + import Control.Monad.Reader (MonadReader, ask, asks) import Control.Monad.Supply.Class (MonadSupply) diff --git a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs index eeaafe0..8b42305 100644 --- a/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs @@ -13,8 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.CodeGen.JS.Optimizer.Inliner ( inlineVariables, inlineValues, @@ -26,9 +24,9 @@ module Language.PureScript.CodeGen.JS.Optimizer.Inliner ( evaluateIifes ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative) -#endif +import Prelude () +import Prelude.Compat + import Control.Monad.Supply.Class (MonadSupply, freshName) import Data.Maybe (fromMaybe) diff --git a/src/Language/PureScript/Docs/ParseAndDesugar.hs b/src/Language/PureScript/Docs/ParseAndDesugar.hs index b422748..a8b107f 100644 --- a/src/Language/PureScript/Docs/ParseAndDesugar.hs +++ b/src/Language/PureScript/Docs/ParseAndDesugar.hs @@ -1,17 +1,16 @@ {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Docs.ParseAndDesugar ( parseAndDesugar , ParseDesugarError(..) ) where +import Prelude () +import Prelude.Compat + import qualified Data.Map as M import Control.Arrow (first) import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Trans.Except import Control.Monad.Writer.Strict (runWriterT) @@ -53,8 +52,8 @@ parseAndDesugar :: -> ([Bookmark] -> [P.Module] -> IO a) -> IO (Either ParseDesugarError a) parseAndDesugar inputFiles depsFiles callback = do - inputFiles' <- mapM (parseAs Local) inputFiles - depsFiles' <- mapM (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles + inputFiles' <- traverse (parseAs Local) inputFiles + depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles runExceptT $ do ms <- parseFiles (inputFiles' ++ depsFiles') @@ -122,7 +121,7 @@ desugar :: [P.Module] -> Either P.MultipleErrors [P.Module] desugar = P.evalSupplyT 0 . desugar' where desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module] - desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports [] + desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports [] ignoreWarnings m = liftM fst (runWriterT m) parseFile :: FilePath -> IO (FilePath, String) diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index ec290be..1177391 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -49,9 +49,7 @@ renderDeclarationWithOptions opts Declaration{..} = [ keywordClass ] ++ maybeToList superclasses ++ [renderType' (typeApp declTitle args)] - ++ if any (isTypeClassMember . cdeclInfo) declChildren - then [keywordWhere] - else [] + ++ [keywordWhere | any (isTypeClassMember . cdeclInfo) declChildren] where superclasses @@ -73,11 +71,7 @@ renderChildDeclarationWithOptions :: RenderTypeOptions -> ChildDeclaration -> Re renderChildDeclarationWithOptions opts ChildDeclaration{..} = mintersperse sp $ case cdeclInfo of ChildInstance constraints ty -> - [ keywordInstance - , ident cdeclTitle - , syntax "::" - ] ++ maybeToList (renderConstraints constraints) - ++ [ renderType' ty ] + maybeToList (renderConstraints constraints) ++ [ renderType' ty ] ChildDataConstructor args -> [ renderType' typeApp' ] where diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index 1af0c09..1d6766e 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | Functions for producing RenderedCode values from PureScript Type values. module Language.PureScript.Docs.RenderedCode.Render ( @@ -11,12 +9,11 @@ module Language.PureScript.Docs.RenderedCode.Render ( defaultRenderTypeOptions, renderTypeWithOptions ) where + +import Prelude () +import Prelude.Compat -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid ((<>), mconcat, mempty) -#else import Data.Monoid ((<>)) -#endif import Data.Maybe (fromMaybe) import Control.Arrow ((<+>)) diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 63e2b21..8ae8760 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -- | Data types and functions for representing a simplified form of PureScript -- code, intended for use in e.g. HTML documentation. @@ -31,11 +30,9 @@ module Language.PureScript.Docs.RenderedCode.Types , keywordWhere ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), (*>), pure) -import Data.Foldable -import Data.Monoid -#endif +import Prelude () +import Prelude.Compat + import qualified Data.Aeson as A import Data.Aeson.BetterErrors import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 131f0a1..15ec473 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -2,7 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Docs.Types ( module Language.PureScript.Docs.Types @@ -10,10 +9,10 @@ module Language.PureScript.Docs.Types ) where +import Prelude () +import Prelude.Compat + import Control.Arrow (first, (***)) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<$), (<*>), pure) -#endif import Control.Monad (when) import Data.Maybe (mapMaybe) import Data.Version diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a5618f9..5c675ed 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -15,31 +15,24 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Errors where +import Prelude () +import Prelude.Compat + import Data.Either (lefts, rights) import Data.List (intercalate, transpose, nub, nubBy) import Data.Function (on) -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (fold, foldMap) -import Data.Traversable (traverse) -#else import Data.Foldable (fold) -#endif import qualified Data.Map as M import Control.Monad -import Control.Monad.Unify import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*>), Applicative, pure) -#endif import Control.Monad.Trans.State.Lazy -import Control.Arrow(first) +import Control.Arrow (first) import Language.PureScript.Crash import Language.PureScript.AST @@ -144,7 +137,11 @@ data SimpleErrorMessage | ClassOperator ProperName Ident | MisleadingEmptyTypeImport ModuleName ProperName | ImportHidingModule ModuleName - deriving Show + | UnusedImport ModuleName + | UnusedExplicitImport ModuleName [String] + | UnusedDctorImport ProperName + | UnusedDctorExplicitImport ProperName [ProperName] + deriving (Show) -- | Error message hints, providing more detailed information about failure. data ErrorMessageHint @@ -181,12 +178,6 @@ data HintCategory data ErrorMessage = ErrorMessage [ErrorMessageHint] SimpleErrorMessage deriving (Show) -instance UnificationError Type ErrorMessage where - occursCheckFailed t = ErrorMessage [] $ InfiniteType t - -instance UnificationError Kind ErrorMessage where - occursCheckFailed k = ErrorMessage [] $ InfiniteKind k - -- | -- Get the error code for a particular error type -- @@ -280,6 +271,11 @@ errorCode em = case unwrapErrorMessage em of ClassOperator{} -> "ClassOperator" MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport" ImportHidingModule{} -> "ImportHidingModule" + UnusedImport{} -> "UnusedImport" + UnusedExplicitImport{} -> "UnusedExplicitImport" + UnusedDctorImport{} -> "UnusedDctorImport" + UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport" + -- | -- A stack trace for an error @@ -287,12 +283,6 @@ errorCode em = case unwrapErrorMessage em of newtype MultipleErrors = MultipleErrors { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid) -instance UnificationError Type MultipleErrors where - occursCheckFailed t = MultipleErrors [occursCheckFailed t] - -instance UnificationError Kind MultipleErrors where - occursCheckFailed k = MultipleErrors [occursCheckFailed k] - -- | Check whether a collection of errors is empty or not. nonEmpty :: MultipleErrors -> Bool nonEmpty = not . null . runMultipleErrors @@ -322,7 +312,7 @@ addHint hint = onErrorMessages $ \(ErrorMessage hints se) -> ErrorMessage (hint data LabelType = TypeLabel | SkolemLabel String deriving (Show, Read, Eq, Ord) -- | A map from rigid type variable name/unknown variable pairs to new variables. -type UnknownMap = M.Map (LabelType, Unknown) Unknown +type UnknownMap = M.Map (LabelType, Int) Int -- | How critical the issue is data Level = Error | Warning deriving Show @@ -336,7 +326,7 @@ unwrapErrorMessage (ErrorMessage _ se) = se replaceUnknowns :: Type -> State UnknownMap Type replaceUnknowns = everywhereOnTypesM replaceTypes where - lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap) + lookupTable :: (LabelType, Int) -> UnknownMap -> (Int, UnknownMap) lookupTable x m = case M.lookup x m of Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m) Just i -> (i, m) @@ -528,7 +518,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderSimpleErrorMessage (EscapedSkolem binding) = paras $ [ line "A type variable has escaped its scope." ] <> foldMap (\expr -> [ line "Relevant expression: " - , indent $ prettyPrintValue expr + , indent $ prettyPrintValue valueDepth expr ]) binding renderSimpleErrorMessage (TypesDoNotUnify t1 t2) = paras [ line "Could not match type" @@ -583,7 +573,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderSimpleErrorMessage (DuplicateLabel l expr) = paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ] <> foldMap (\expr' -> [ line "Relevant expression: " - , indent $ prettyPrintValue expr' + , indent $ prettyPrintValue valueDepth expr' ]) expr renderSimpleErrorMessage (DuplicateTypeArgument name) = line $ "Type argument " ++ show name ++ " appears more than once." @@ -592,7 +582,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderSimpleErrorMessage (ArgListLengthsDiffer ident) = line $ "Argument list lengths differ in declaration " ++ showIdent ident renderSimpleErrorMessage (OverlappingArgNames ident) = - line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . showIdent) ident + line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration " ++) . showIdent) ident renderSimpleErrorMessage (MissingClassMember ident) = line $ "Type class member " ++ showIdent ident ++ " has not been implemented." renderSimpleErrorMessage (ExtraneousClassMember ident className) = @@ -609,7 +599,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression." renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) = paras [ line "Expression" - , indent $ prettyPrintValue expr + , indent $ prettyPrintValue valueDepth expr , line "does not have type" , indent $ typeAsBox ty ] @@ -621,7 +611,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ line "A function of type" , indent $ typeAsBox fn , line "can not be applied to the argument" - , indent $ prettyPrintValue arg + , indent $ prettyPrintValue valueDepth arg ] renderSimpleErrorMessage TypeSynonymInstance = line "Type class instances for type synonyms are disallowed." @@ -688,6 +678,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError paras [ line "An exhaustivity check was abandoned due to too many possible cases." , line "You may want to decompose your data types into smaller types." ] + renderSimpleErrorMessage (UnusedImport name) = + line $ "The import of module " ++ runModuleName name ++ " is redundant" + + renderSimpleErrorMessage (UnusedExplicitImport name names) = + paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:" + , indent $ paras $ map line names ] + + renderSimpleErrorMessage (UnusedDctorImport name) = + line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used" + + renderSimpleErrorMessage (UnusedDctorExplicitImport name names) = + paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:" + , indent $ paras $ map (line .runProperName) names ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box renderHint (ErrorUnifyingTypes t1 t2) detail = @@ -702,7 +705,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderHint (ErrorInExpression expr) detail = paras [ detail , Box.hsep 1 Box.top [ Box.text "in the expression" - , prettyPrintValue expr + , prettyPrintValue valueDepth expr ] ] renderHint (ErrorInModule mn) detail = @@ -738,13 +741,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderHint (ErrorInferringType expr) detail = paras [ detail , Box.hsep 1 Box.top [ line "while inferring the type of" - , prettyPrintValue expr + , prettyPrintValue valueDepth expr ] ] renderHint (ErrorCheckingType expr ty) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking that expression" - , prettyPrintValue expr + , prettyPrintValue valueDepth expr ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type" , typeAsBox ty @@ -753,19 +756,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError renderHint (ErrorCheckingAccessor expr prop) detail = paras [ detail , Box.hsep 1 Box.top [ line "while checking type of property accessor" - , prettyPrintValue (Accessor prop expr) + , prettyPrintValue valueDepth (Accessor prop expr) ] ] renderHint (ErrorInApplication f t a) detail = paras [ detail , Box.hsep 1 Box.top [ line "while applying a function" - , prettyPrintValue f + , prettyPrintValue valueDepth f ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type" , typeAsBox t ] , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument" - , prettyPrintValue a + , prettyPrintValue valueDepth a ] ] renderHint (ErrorInDataConstructor nm) detail = @@ -805,6 +808,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError , detail ] + valueDepth :: Int + valueDepth | full = 1000 + | otherwise = 3 + levelText :: String levelText = case level of Error -> "error" @@ -944,19 +951,17 @@ renderBox = unlines . map trimEnd . lines . Box.render trimEnd = reverse . dropWhile (== ' ') . reverse -- | --- Interpret multiple errors and warnings in a monad supporting errors and warnings --- -interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a -interpretMultipleErrorsAndWarnings (err, ws) = do - tell ws - either throwError return err - --- | -- Rethrow an error with a more detailed error message in the case of failure -- rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) +reifyErrors :: (Functor m, MonadError e m) => m a -> m (Either e a) +reifyErrors ma = catchError (fmap Right ma) (return . Left) + +reflectErrors :: (MonadError e m) => m (Either e a) -> m a +reflectErrors ma = ma >>= either throwError return + warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a warnAndRethrow f = rethrow f . censor f diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index bed882b..036a748 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -13,7 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} @@ -27,13 +26,13 @@ module Language.PureScript.Externs , applyExternsFileToEnvironment ) where +import Prelude () +import Prelude.Compat + import Data.List (find, foldl') import Data.Maybe (mapMaybe, maybeToList, fromMaybe) import Data.Foldable (fold) import Data.Version (showVersion) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif import Data.Aeson.TH import qualified Data.Map as M diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 1c63b7d..bf37e48 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -14,18 +14,15 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Kinds where +import Prelude () +import Prelude.Compat + import Data.Data import qualified Data.Aeson.TH as A -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Monad.Unify (Unknown) - -- | -- The data type of kinds -- @@ -33,7 +30,7 @@ data Kind -- | -- Unification variable of type Kind -- - = KUnknown Unknown + = KUnknown Int -- | -- The kind of types -- diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 2e1c0fa..10991c8 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -12,22 +12,20 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Linter (lint, module L) where +import Prelude () +import Prelude.Compat + import Data.List (mapAccumL, nub, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid import qualified Data.Set as S -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Writer.Class import Language.PureScript.Crash @@ -36,6 +34,7 @@ import Language.PureScript.Names import Language.PureScript.Errors import Language.PureScript.Types import Language.PureScript.Linter.Exhaustive as L +import Language.PureScript.Linter.Imports as L -- | Lint the PureScript AST. -- | diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 4adc578..f36cc21 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -18,20 +18,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Linter.Exhaustive ( checkExhaustive , checkExhaustiveModule ) where +import Prelude () +import Prelude.Compat + import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.List (foldl', sortBy, nub) import Data.Function (on) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (sequenceA) -#endif import Control.Monad (unless) import Control.Applicative diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs new file mode 100644 index 0000000..01f195a --- /dev/null +++ b/src/Language/PureScript/Linter/Imports.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +module Language.PureScript.Linter.Imports (findUnusedImports, Name(..), UsedImports()) where + +import Prelude () +import Prelude.Compat + +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import Data.List ((\\), find, intersect) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class +import Control.Monad(unless,when) +import Data.Foldable (forM_) + +import Language.PureScript.AST.Declarations +import Language.PureScript.AST.SourcePos +import Language.PureScript.Names as P + +import Language.PureScript.Errors +import Language.PureScript.Sugar.Names.Env +import Language.PureScript.Sugar.Names.Imports + +import qualified Language.PureScript.Constants as C + +-- | Imported name used in some type or expression. +data Name = IdentName (Qualified Ident) | IsProperName (Qualified ProperName) | DctorName (Qualified ProperName) + +-- | Map of module name to list of imported names from that module which have been used. +type UsedImports = M.Map ModuleName [Name] + +-- | +-- Find and warn on any unused import statements (qualified or unqualified) +-- or references in an explicit import list. +-- +findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m () +findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do + imps <- findImports mdecls + forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $ + forM_ decls $ \(ss, declType, qualifierName) -> + censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $ + let names = sugarNames mni ++ M.findWithDefault [] mni usedImps + usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names + usedDctors = mapMaybe (matchDctor qualifierName) names + in case declType of + Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni + Explicit declrefs -> do + let idents = mapMaybe runDeclRef declrefs + let diff = idents \\ usedNames + case (length diff, length idents) of + (0, _) -> return () + (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni + _ -> tell $ errorMessage $ UnusedExplicitImport mni diff + + -- If we've not already warned a type is unused, check its data constructors + forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do + let allCtors = dctorsForType mni tn + when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of + (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn + (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn + (Just ctors, _) -> + let ddiff = ctors \\ usedDctors + in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff + _ -> return () + return () + + _ -> return () + where + sugarNames :: ModuleName -> [ Name ] + sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ] + sugarNames _ = [] + + -- rely on exports being elaborated by this point + alwaysUsedModules :: [ ModuleName ] + alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports + where + isExport (ModuleRef mn) = Just mn + isExport _ = Nothing + + qnameUsed :: Maybe ModuleName -> Bool + qnameUsed (Just qn) = qn `elem` alwaysUsedModules + qnameUsed Nothing = False + + dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)] + dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env + + dctorsForType :: ModuleName -> ProperName -> [ProperName] + dctorsForType mn tn = + maybe [] getDctors (find matches $ dtys mn) + where + matches ((ty, _),_) = ty == tn + getDctors ((_,ctors),_) = ctors + + typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName + typeForDCtor mn pn = + getTy <$> find matches (dtys mn) + where + matches ((_, ctors), _) = pn `elem` ctors + getTy ((ty, _), _) = ty + + +matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String +matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x +matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperName x +matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x +matchName _ _ _ = Nothing + +matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName +matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x +matchDctor _ _ = Nothing + +runDeclRef :: DeclarationRef -> Maybe String +runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref +runDeclRef (ValueRef ident) = Just $ showIdent ident +runDeclRef (TypeRef pn _) = Just $ runProperName pn +runDeclRef _ = Nothing + +getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName]) +getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref +getTypeRef (TypeRef pn x) = Just (pn, x) +getTypeRef _ = Nothing + +addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage +addModuleLocError sp err = + case sp of + Just pos -> withPosition pos err + _ -> err diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 7682066..4888ca6 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -21,7 +21,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Make ( @@ -38,14 +37,16 @@ module Language.PureScript.Make , buildMakeActions ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import Control.Monad +import Prelude () +import Prelude.Compat + +import Control.Monad hiding (sequence) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except -import Control.Monad.Reader +import Control.Monad.IO.Class +import Control.Monad.Reader (MonadReader(..), ReaderT(..)) import Control.Monad.Logger import Control.Monad.Supply import Control.Monad.Base (MonadBase(..)) @@ -58,10 +59,6 @@ import Data.Maybe (fromMaybe, catMaybes) import Data.Time.Clock import Data.String (fromString) import Data.Foldable (for_) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty, mconcat) -import Data.Traversable (traverse) -#endif import Data.Traversable (for) import Data.Version (showVersion) import Data.Aeson (encode, decode) @@ -207,12 +204,12 @@ make MakeActions{..} ms = do -- We need to wait for dependencies to be built, before checking if the current -- module should be rebuilt, so the first thing to do is to wait on the -- MVars for the module's dependencies. - mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps + mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps case mexterns of Just (_, externs) -> do outputTimestamp <- getOutputTimestamp moduleName - dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps + dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps inputTimestamp <- getInputTimestamp moduleName let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index 4a0ef87..c48c472 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -37,6 +37,7 @@ import Data.Maybe (fromMaybe) import Control.Applicative import Control.Arrow ((+++)) import Control.Monad.Error.Class (MonadError(..)) +import Control.Parallel.Strategies (withStrategy, parList, rseq) import Language.PureScript.AST import Language.PureScript.Comments @@ -274,23 +275,26 @@ parseModule = do let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) return $ Module ss comments name decls exports --- | --- Parse a collection of modules --- +-- | Parse a collection of modules in parallel parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) => (k -> FilePath) -> [(k, String)] -> m [(k, Module)] parseModulesFromFiles toFilePath input = do - modules <- parU input $ \(k, content) -> do + modules <- flip parU id $ map wrapError $ inParallel $ flip map input $ \(k, content) -> do let filename = toFilePath k - ts <- wrapError $ lex filename content - ms <- wrapError $ runTokenParser filename parseModules ts + ts <- lex filename content + ms <- runTokenParser filename parseModules ts return (k, ms) return $ collect modules where - wrapError :: Either P.ParseError a -> m a - wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return collect :: [(k, [v])] -> [(k, v)] collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ] + wrapError :: Either P.ParseError a -> m a + wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return + -- It is enough to force each parse result to WHNF, since success or failure can't be + -- determined until the end of the file, so this effectively distributes parsing of each file + -- to a different spark. + inParallel :: [Either P.ParseError (k, [Module])] -> [Either P.ParseError (k, [Module])] + inParallel = withStrategy (parList rseq) toPositionedError :: P.ParseError -> ErrorMessage toPositionedError perr = ErrorMessage [ PositionedError (SourceSpan name start end) ] (ErrorParsingModule perr) @@ -330,9 +334,14 @@ parseObjectLiteral :: TokenParser Expr parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue) parseIdentifierAndValue :: TokenParser (String, Maybe Expr) -parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon) - <*> (C.indented *> val) +parseIdentifierAndValue = + do + name <- C.indented *> lname + b <- P.option (Just $ Var $ Qualified Nothing (Ident name)) rest + return (name, b) + <|> (,) <$> (C.indented *> stringLiteral) <*> rest where + rest = C.indented *> colon *> C.indented *> val val = (Just <$> parseValue) <|> (underscore *> pure Nothing) parseAbs :: TokenParser Expr @@ -410,8 +419,8 @@ parseInfixExpr = P.between tick tick parseValue parseOperatorSection :: TokenParser Expr parseOperatorSection = parens $ left <|> right where - right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom) - left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr + right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> indexersAndAccessors) + left = flip OperatorSection <$> (Left <$> indexersAndAccessors) <* indented <*> parseInfixExpr parsePropertyUpdate :: TokenParser (String, Maybe Expr) parsePropertyUpdate = do @@ -445,21 +454,25 @@ parseDoNotationElement = P.choice parseObjectGetter :: TokenParser Expr parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) +-- | Expressions including indexers and record updates +indexersAndAccessors :: TokenParser Expr +indexersAndAccessors = C.buildPostfixParser postfixTable parseValueAtom + where + postfixTable = [ parseAccessor + , P.try . parseUpdaterBody . Just ] + -- | -- Parse a value -- parseValue :: TokenParser Expr parseValue = withSourceSpan PositionedValue (P.buildExpressionParser operators - . C.buildPostfixParser postfixTable2 + . C.buildPostfixParser postfixTable $ indexersAndAccessors) P.<?> "expression" where - indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom - postfixTable1 = [ parseAccessor - , P.try . parseUpdaterBody . Just ] - postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v - , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v - ] + postfixTable = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v + , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v + ] operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus) ] , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident -> @@ -513,11 +526,13 @@ parseNullBinder :: TokenParser Binder parseNullBinder = underscore *> return NullBinder parseIdentifierAndBinder :: TokenParser (String, Binder) -parseIdentifierAndBinder = do - name <- lname <|> stringLiteral - C.indented *> (equals <|> colon) - binder <- C.indented *> parseBinder - return (name, binder) +parseIdentifierAndBinder = + do name <- lname + b <- P.option (VarBinder (Ident name)) rest + return (name, b) + <|> (,) <$> stringLiteral <*> rest + where + rest = C.indented *> (equals <|> colon) *> C.indented *> parseBinder -- | -- Parse a binder diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs index 43cb04e..a25f7d8 100644 --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -13,16 +13,15 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Parser.JS ( ForeignJS() , parseForeignModulesFromFiles ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((*>), (<*)) -#endif +import Prelude () +import Prelude.Compat hiding (lex) + import Control.Monad (forM_, when, msum) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -32,7 +31,6 @@ import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer -import Prelude hiding (lex) import qualified Data.Map as M import qualified Text.Parsec as PS diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index f45473c..83e62da 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -13,18 +13,16 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.Parser.Kinds ( parseKind ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Kinds import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index a4a2857..acdb940 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -158,7 +158,7 @@ instance Show PositionedToken where show = prettyPrintToken . ptToken lex :: FilePath -> String -> Either P.ParseError [PositionedToken] -lex filePath input = P.parse parseTokens filePath input +lex = P.parse parseTokens parseTokens :: P.Parsec String u [PositionedToken] parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 51eba66..2a1f6e0 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -13,20 +13,18 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.Pretty.JS ( prettyPrintJS ) where -import Data.List +import Prelude () +import Prelude.Compat + +import Data.List hiding (concat, concatMap) import Data.Maybe (fromMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow ((<+>)) -import Control.Monad.State +import Control.Monad.State hiding (sequence) import Control.PatternArrows import qualified Control.Arrow as A @@ -166,8 +164,14 @@ string s = '"' : concatMap encodeChar s ++ "\"" encodeChar '\r' = "\\r" encodeChar '"' = "\\\"" encodeChar '\\' = "\\\\" + encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate ("\\u" ++ showHex lowSurrogate "") + where + (h, l) = divMod (fromEnum c - 0x10000) 0x400 + highSurrogate = h + 0xD800 + lowSurrogate = l + 0xDC00 encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) "" encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) "" + encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) "" encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) "" encodeChar c = [c] @@ -199,7 +203,7 @@ app :: Pattern PrinterState JS (String, JS) app = mkPattern' match where match (JSApp val args) = do - jss <- mapM prettyPrintJS' args + jss <- traverse prettyPrintJS' args return (intercalate ", " jss, val) match _ = mzero diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 20ceabe..717e610 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -133,7 +133,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom ] , [ Wrap constrained $ \deps ty -> constraintsAsBox deps ty ] , [ Wrap forall_ $ \idents ty -> text ("forall " ++ unwords idents ++ ". ") <> ty ] - , [ Wrap kinded $ \k ty -> ty `before` (text (" :: " ++ prettyPrintKind k)) ] + , [ Wrap kinded $ \k ty -> ty `before` text (" :: " ++ prettyPrintKind k) ] ] forall_ :: Pattern () Type ([String], Type) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 7c19815..3064bc2 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -13,8 +13,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.Pretty.Values ( prettyPrintValue, prettyPrintBinder, @@ -40,101 +38,107 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl where toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a -prettyPrintObject :: [(String, Maybe Expr)] -> Box -prettyPrintObject = list '{' '}' prettyPrintObjectProperty +ellipsis :: Box +ellipsis = text "..." + +prettyPrintObject :: Int -> [(String, Maybe Expr)] -> Box +prettyPrintObject d = list '{' '}' prettyPrintObjectProperty where prettyPrintObjectProperty :: (String, Maybe Expr) -> Box - prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") prettyPrintValue value + prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value -- | Pretty-print an expression -prettyPrintValue :: Expr -> Box -prettyPrintValue (IfThenElse cond th el) = - (text "if " <> prettyPrintValueAtom cond) - // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom th - , text "else " <> prettyPrintValueAtom el +prettyPrintValue :: Int -> Expr -> Box +prettyPrintValue d _ | d < 0 = text "..." +prettyPrintValue d (IfThenElse cond th el) = + (text "if " <> prettyPrintValueAtom (d - 1) cond) + // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th + , text "else " <> prettyPrintValueAtom (d - 1) el ]) -prettyPrintValue (Accessor prop val) = prettyPrintValueAtom val <> text ("." ++ show prop) -prettyPrintValue (ObjectUpdate o ps) = prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue val) ps -prettyPrintValue (ObjectUpdater o ps) = maybe (text "_") prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") prettyPrintValue val) ps -prettyPrintValue (App val arg) = prettyPrintValueAtom val `beforeWithSpace` prettyPrintValueAtom arg -prettyPrintValue (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue val) -prettyPrintValue (TypeClassDictionaryConstructorApp className ps) = - text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom ps -prettyPrintValue (Case values binders) = - (text "case " <> foldl1 beforeWithSpace (map prettyPrintValueAtom values) <> text " of") // - moveRight 2 (vcat left (map prettyPrintCaseAlternative binders)) -prettyPrintValue (Let ds val) = +prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop) +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps +prettyPrintValue d (ObjectUpdater o ps) = maybe (text "_") (prettyPrintValueAtom (d - 1)) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") (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 ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) +prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = + text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps +prettyPrintValue d (Case values binders) = + (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") // + moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) +prettyPrintValue d (Let ds val) = text "let" // - moveRight 2 (vcat left (map prettyPrintDeclaration ds)) // - (text "in " <> prettyPrintValue val) -prettyPrintValue (Do els) = - text "do " <> vcat left (map prettyPrintDoNotationElement els) -prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys -prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) -prettyPrintValue (TypedValue _ val _) = prettyPrintValue val -prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val -prettyPrintValue expr = prettyPrintValueAtom expr + moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) // + (text "in " <> prettyPrintValue (d - 1) val) +prettyPrintValue d (Do els) = + text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els) +prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys +prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name) +prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val +prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val +prettyPrintValue d expr = prettyPrintValueAtom d expr -- | Pretty-print an atomic expression, adding parentheses if necessary. -prettyPrintValueAtom :: Expr -> Box -prettyPrintValueAtom (NumericLiteral n) = text $ either show show n -prettyPrintValueAtom (StringLiteral s) = text $ show s -prettyPrintValueAtom (CharLiteral c) = text $ show c -prettyPrintValueAtom (BooleanLiteral True) = text "true" -prettyPrintValueAtom (BooleanLiteral False) = text "false" -prettyPrintValueAtom (ArrayLiteral xs) = list '[' ']' prettyPrintValue xs -prettyPrintValueAtom (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps -prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps -prettyPrintValueAtom (ObjectGetter prop) = text $ "_." ++ show prop -prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name) -prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident) -prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")" -prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")" -prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValueAtom val -prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val -prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")" - -prettyPrintDeclaration :: Declaration -> Box -prettyPrintDeclaration (TypeDeclaration ident ty) = +prettyPrintValueAtom :: Int -> Expr -> Box +prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n +prettyPrintValueAtom _ (StringLiteral s) = text $ show s +prettyPrintValueAtom _ (CharLiteral c) = text $ show c +prettyPrintValueAtom _ (BooleanLiteral True) = text "true" +prettyPrintValueAtom _ (BooleanLiteral False) = text "false" +prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs +prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps +prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps +prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop +prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name) +prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident) +prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")" +prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")" +prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val +prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val +prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")" + +prettyPrintDeclaration :: Int -> Declaration -> Box +prettyPrintDeclaration d _ | d < 0 = ellipsis +prettyPrintDeclaration _ (TypeDeclaration ident ty) = text (showIdent ident ++ " :: ") <> typeAsBox ty -prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = - text (showIdent ident ++ " = ") <> prettyPrintValue val -prettyPrintDeclaration (BindingGroupDeclaration ds) = - vsep 1 left (map (prettyPrintDeclaration . toDecl) ds) +prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) = + text (showIdent ident ++ " = ") <> prettyPrintValue (d - 1) val +prettyPrintDeclaration d (BindingGroupDeclaration ds) = + vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds) where toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e) -prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d -prettyPrintDeclaration _ = internalError "Invalid argument to prettyPrintDeclaration" +prettyPrintDeclaration d (PositionedDeclaration _ _ decl) = prettyPrintDeclaration d decl +prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" -prettyPrintCaseAlternative :: CaseAlternative -> Box -prettyPrintCaseAlternative (CaseAlternative binders result) = +prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box +prettyPrintCaseAlternative d _ | d < 0 = ellipsis +prettyPrintCaseAlternative d (CaseAlternative binders result) = text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result where prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box prettyPrintResult (Left gs) = vcat left (map prettyPrintGuardedValue gs) - prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v + prettyPrintResult (Right v) = text " -> " <> prettyPrintValue (d - 1) v prettyPrintGuardedValue :: (Guard, Expr) -> Box prettyPrintGuardedValue (grd, val) = foldl1 before [ text " | " - , prettyPrintValue grd + , prettyPrintValue (d - 1) grd , text " -> " - , prettyPrintValue val + , prettyPrintValue (d - 1) val ] -prettyPrintDoNotationElement :: DoNotationElement -> Box -prettyPrintDoNotationElement (DoNotationValue val) = - prettyPrintValue val -prettyPrintDoNotationElement (DoNotationBind binder val) = - text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue val -prettyPrintDoNotationElement (DoNotationLet ds) = +prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box +prettyPrintDoNotationElement d _ | d < 0 = ellipsis +prettyPrintDoNotationElement d (DoNotationValue val) = + prettyPrintValue d val +prettyPrintDoNotationElement d (DoNotationBind binder val) = + text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue d val +prettyPrintDoNotationElement d (DoNotationLet ds) = text "let" // - moveRight 2 (vcat left (map prettyPrintDeclaration ds)) -prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el + moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) +prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el prettyPrintBinderAtom :: Binder -> String - prettyPrintBinderAtom NullBinder = "_" prettyPrintBinderAtom (StringBinder str) = show str prettyPrintBinderAtom (CharBinder c) = show c diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index e80c964..904607e 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -2,24 +2,28 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Publish ( preparePackage , preparePackage' , PrepareM() , runPrepareM + , warn + , userError + , internalError + , otherError , PublishOptions(..) , defaultPublishOptions , getGitWorkingTreeStatus - , requireCleanWorkingTree + , checkCleanWorkingTree , getVersionFromGitTag , getBowerInfo , getModulesAndBookmarks , getResolvedDependencies ) where -import Prelude hiding (userError) +import Prelude () +import Prelude.Compat hiding (userError) import Data.Maybe import Data.Char (isSpace) @@ -28,15 +32,13 @@ import Data.List.Split (splitOn) import Data.List.NonEmpty (NonEmpty(..)) import Data.Version import Data.Function (on) +import Data.Foldable (traverse_) import Safe (headMay) import Data.Aeson.BetterErrors import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Category ((>>>)) import Control.Arrow ((***)) import Control.Exception (catch, try) @@ -65,11 +67,14 @@ data PublishOptions = PublishOptions { -- | How to obtain the version tag and version that the data being -- generated will refer to. publishGetVersion :: PrepareM (String, Version) + , -- | What to do when the working tree is dirty + publishWorkingTreeDirty :: PrepareM () } defaultPublishOptions :: PublishOptions defaultPublishOptions = PublishOptions { publishGetVersion = getVersionFromGitTag + , publishWorkingTreeDirty = userError DirtyWorkingTree } -- | Attempt to retrieve package metadata from the current directory. @@ -121,10 +126,10 @@ preparePackage' opts = do exists <- liftIO (doesFileExist "bower.json") unless exists (userError BowerJSONNotFound) - requireCleanWorkingTree + checkCleanWorkingTree opts pkgMeta <- liftIO (Bower.decodeFile "bower.json") - >>= flip catchLeft (userError . CouldntParseBowerJSON) + >>= flip catchLeft (userError . CouldntDecodeBowerJSON) (pkgVersionTag, pkgVersion) <- publishGetVersion opts pkgGithub <- getBowerInfo pkgMeta (pkgBookmarks, pkgModules) <- getModulesAndBookmarks @@ -157,11 +162,11 @@ getGitWorkingTreeStatus = do then Clean else Dirty -requireCleanWorkingTree :: PrepareM () -requireCleanWorkingTree = do +checkCleanWorkingTree :: PublishOptions -> PrepareM () +checkCleanWorkingTree opts = do status <- getGitWorkingTreeStatus unless (status == Clean) $ - userError DirtyWorkingTree + publishWorkingTreeDirty opts getVersionFromGitTag :: PrepareM (String, Version) getVersionFromGitTag = do @@ -304,7 +309,7 @@ asDependencyStatus = do warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM () warnUndeclared declared actual = - mapM_ (warn . UndeclaredDependency) (actual \\ declared) + traverse_ (warn . UndeclaredDependency) (actual \\ declared) handleDeps :: [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)] @@ -314,8 +319,8 @@ handleDeps deps = do (x:xs) -> userError (MissingDependencies (x :| xs)) [] -> do - mapM_ (warn . NoResolvedVersion) noVersion - withVersions <- catMaybes <$> mapM tryExtractVersion' installed + traverse_ (warn . NoResolvedVersion) noVersion + withVersions <- catMaybes <$> traverse tryExtractVersion' installed filterM (liftIO . isPureScript . bowerDir . fst) withVersions where diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index 7224438..c001de8 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Publish.ErrorsWarnings ( PackageError(..) @@ -16,16 +15,13 @@ module Language.PureScript.Publish.ErrorsWarnings , renderWarnings ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>)) -#endif +import Prelude () +import Prelude.Compat + import Data.Aeson.BetterErrors import Data.Version import Data.Maybe import Data.Monoid -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (foldMap) -#endif import Data.List (intersperse, intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -33,7 +29,7 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as T import Control.Exception (IOException) -import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName) +import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError) import qualified Web.Bower.PackageMeta as Bower import qualified Language.PureScript as P @@ -53,14 +49,14 @@ data PackageWarning = NoResolvedVersion PackageName | UndeclaredDependency PackageName | UnacceptableVersion (PackageName, String) + | DirtyWorkingTree_Warn deriving (Show) -- | An error that should be fixed by the user. data UserError = BowerJSONNotFound | BowerExecutableNotFound [String] -- list of executable names tried - | CouldntParseBowerJSON (ParseError BowerError) - | BowerJSONNameMissing + | CouldntDecodeBowerJSON (ParseError BowerError) | TagMustBeCheckedOut | AmbiguousVersions [Version] -- Invariant: should contain at least two elements | BadRepositoryField RepositoryFieldError @@ -134,21 +130,12 @@ displayUserError e = case e of ]) where format = intercalate ", " . map show - CouldntParseBowerJSON err -> - vcat - [ successivelyIndented - [ "The bower.json file could not be parsed as JSON:" - , "aeson reported: " ++ show err - ] - , para "Please ensure that your bower.json file is valid JSON." - ] - BowerJSONNameMissing -> + CouldntDecodeBowerJSON err -> vcat - [ successivelyIndented - [ "In bower.json:" - , "the \"name\" key was not found." - ] - , para "Please give your package a name first." + [ para "There was a problem with your bower.json file:" + , indented (vcat (map (para . T.unpack) (displayError showBowerError err))) + , spacer + , para "Please ensure that your bower.json file is valid." ] TagMustBeCheckedOut -> vcat @@ -164,9 +151,9 @@ displayUserError e = case e of , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")") , spacer , para (concat - [ "If the version you are publishing is not yet tagged, you might want to use" - , "the --dry-run flag instead, which removes this requirement. Run" - , "psc-publish --help for more details." + [ "If the version you are publishing is not yet tagged, you might " + , "want to use the --dry-run flag instead, which removes this " + , "requirement. Run psc-publish --help for more details." ]) ] AmbiguousVersions vs -> @@ -293,21 +280,24 @@ data CollectedWarnings = CollectedWarnings { noResolvedVersions :: [PackageName] , undeclaredDependencies :: [PackageName] , unacceptableVersions :: [(PackageName, String)] + , dirtyWorkingTree :: Any } deriving (Show, Eq, Ord) instance Monoid CollectedWarnings where - mempty = CollectedWarnings mempty mempty mempty - mappend (CollectedWarnings as bs cs) (CollectedWarnings as' bs' cs') = - CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') + mempty = CollectedWarnings mempty mempty mempty mempty + mappend (CollectedWarnings as bs cs d) + (CollectedWarnings as' bs' cs' d') = + CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d') collectWarnings :: [PackageWarning] -> CollectedWarnings collectWarnings = foldMap singular where singular w = case w of - NoResolvedVersion pn -> CollectedWarnings [pn] [] [] - UndeclaredDependency pn -> CollectedWarnings [] [pn] [] - UnacceptableVersion t -> CollectedWarnings [] [] [t] + NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty + UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty + UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty + DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True) renderWarnings :: [PackageWarning] -> Box renderWarnings warns = @@ -316,6 +306,9 @@ renderWarnings warns = mboxes = [ go warnNoResolvedVersions noResolvedVersions , go warnUndeclaredDependencies undeclaredDependencies , go warnUnacceptableVersions unacceptableVersions + , if getAny dirtyWorkingTree + then Just warnDirtyWorkingTree + else Nothing ] in case catMaybes mboxes of [] -> nullBox @@ -391,5 +384,12 @@ warnUnacceptableVersions pkgs = where showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ tag +warnDirtyWorkingTree :: Box +warnDirtyWorkingTree = + para (concat + [ "Your working tree is dirty. (Note: this would be an error if it " + , "were not a dry run)" + ]) + printWarnings :: [PackageWarning] -> IO () printWarnings = printToStderr . renderWarnings diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index ab20854..c651bfc 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -16,13 +16,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Renamer (renameInModules) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Prelude () +import Prelude.Compat + import Control.Monad.State import Data.List (find) @@ -135,8 +134,8 @@ renameInDecl isTopLevel (NonRec name val) = do name' <- if isTopLevel then return name else updateScope name NonRec name' <$> renameInValue val renameInDecl isTopLevel (Rec ds) = do - ds' <- mapM updateNames ds - Rec <$> mapM updateValues ds' + ds' <- traverse updateNames ds + Rec <$> traverse updateValues ds' where updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann) updateNames (name, val) = do @@ -155,7 +154,7 @@ renameInValue c@(Constructor{}) = return c renameInValue (Accessor ann prop v) = Accessor ann prop <$> renameInValue v renameInValue (ObjectUpdate ann obj vs) = - ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs + ObjectUpdate ann <$> renameInValue obj <*> traverse (\(name, v) -> (,) name <$> renameInValue v) vs renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v @@ -165,16 +164,16 @@ renameInValue (Var ann (Qualified Nothing name)) = Var ann . Qualified Nothing <$> lookupIdent name renameInValue v@(Var{}) = return v renameInValue (Case ann vs alts) = - newScope $ Case ann <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts + newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts renameInValue (Let ann ds v) = - newScope $ Let ann <$> mapM (renameInDecl False) ds <*> renameInValue v + newScope $ Let ann <$> traverse (renameInDecl False) ds <*> renameInValue v -- | -- Renames within literals. -- renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a) -renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> mapM rename bs -renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> mapM (sndM rename) bs +renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> traverse rename bs +renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> traverse (sndM rename) bs renameInLiteral _ l = return l -- | @@ -182,8 +181,8 @@ renameInLiteral _ l = return l -- renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann) renameInCaseAlternative (CaseAlternative bs v) = newScope $ - CaseAlternative <$> mapM renameInBinder bs - <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v + CaseAlternative <$> traverse renameInBinder bs + <*> eitherM (traverse (pairM renameInValue renameInValue)) renameInValue v -- | -- Renames within binders. @@ -195,6 +194,6 @@ renameInBinder (LiteralBinder ann b) = renameInBinder (VarBinder ann name) = VarBinder ann <$> updateScope name renameInBinder (ConstructorBinder ann tctor dctor bs) = - ConstructorBinder ann tctor dctor <$> mapM renameInBinder bs + ConstructorBinder ann tctor dctor <$> traverse renameInBinder bs renameInBinder (NamedBinder ann name b) = NamedBinder ann <$> updateScope name <*> renameInBinder b diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index ba37227..0b50a5f 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -14,15 +14,14 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar (desugar, module S) where +import Prelude () +import Prelude.Compat + import Control.Monad import Control.Category ((>>>)) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Error.Class (MonadError()) import Control.Monad.Writer.Class (MonadWriter()) import Control.Monad.Supply.Class @@ -67,13 +66,13 @@ import Language.PureScript.Sugar.TypeDeclarations as S desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] desugar externs = map removeSignedLiterals - >>> mapM desugarObjectConstructors - >=> mapM desugarOperatorSections - >=> mapM desugarDoModule + >>> traverse desugarObjectConstructors + >=> traverse desugarOperatorSections + >=> traverse desugarDoModule >=> desugarCasesModule >=> desugarTypeDeclarationsModule >=> desugarImports externs >=> rebracket externs - >=> mapM deriveInstances + >=> traverse deriveInstances >=> desugarTypeClasses externs >=> createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index e0257fc..ff6c03f 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -15,7 +15,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.BindingGroups ( @@ -25,13 +24,12 @@ module Language.PureScript.Sugar.BindingGroups ( collapseBindingGroupsModule ) where +import Prelude () +import Prelude.Compat + import Data.Graph import Data.List (nub, intersect) import Data.Maybe (isJust, mapMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (foldMap) -import Control.Applicative -#endif import Control.Monad ((<=<)) import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index e3e5062..8380d4c 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -16,20 +16,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.CaseDeclarations ( desugarCases, desugarCasesModule ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Crash import Data.Maybe (catMaybes) import Data.List (nub, groupBy) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad ((<=<), forM, replicateM, join, unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 72e6fa7..c91012a 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -16,12 +16,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.DoNotation ( desugarDoModule ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Crash import Language.PureScript.Names import Language.PureScript.AST @@ -29,9 +31,6 @@ import Language.PureScript.Errors import qualified Language.PureScript.Constants as C -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 810acef..2cf496b 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -11,23 +11,22 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.PureScript.Sugar.Names (desugarImports) where +import Prelude () +import Prelude.Compat + import Data.List (find, nub) import Data.Maybe (fromMaybe, mapMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty) -import Control.Applicative (Applicative(..), (<$>), (<*>)) -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer (MonadWriter(..), censor) +import Control.Monad.State.Lazy import qualified Data.Map as M @@ -41,6 +40,7 @@ import Language.PureScript.Externs import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Imports import Language.PureScript.Sugar.Names.Exports +import Language.PureScript.Linter.Imports -- | -- Replaces all local names with qualified names within a list of modules. The @@ -50,7 +50,7 @@ desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWr desugarImports externs modules = do env <- silence $ foldM externsEnv primEnv externs env' <- foldM updateEnv env modules - mapM (renameInModule' env') modules + traverse (renameInModule' env') modules where silence :: m a -> m a silence = censor (const mempty) @@ -103,9 +103,11 @@ desugarImports externs modules = do renameInModule' :: Env -> Module -> m Module renameInModule' env m@(Module _ _ mn _ _) = - rethrow (addHint (ErrorInModule mn)) $ do + warnAndRethrow (addHint (ErrorInModule mn)) $ do let (_, imps, exps) = fromMaybe (internalError "Module is missing in renameInModule'") $ M.lookup mn env - elaborateImports imps <$> renameInModule env imps (elaborateExports exps m) + (m', used) <- flip runStateT M.empty $ renameInModule env imps (elaborateExports exps m) + findUnusedImports m env used + return $ elaborateImports imps m' -- | -- Make all exports for a module explicit. This may still effect modules that @@ -146,29 +148,30 @@ elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls' -- Replaces all local names with qualified names within a module and checks that all existing -- qualified names are valid. -- -renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => Env -> Imports -> Module -> m Module +renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadState UsedImports m) => Env -> Imports -> Module -> m Module renameInModule env imports (Module ss coms mn decls exps) = Module ss coms mn <$> parU decls go <*> pure exps where + (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration) updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d) updateDecl (pos, bound) (DataDeclaration dtype name args dctors) = - (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors) + (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) = (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) = (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds) updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) = - (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure 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 s d = return (s, d) - + -- updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v) @@ -189,7 +192,7 @@ renameInModule env imports (Module ss coms mn decls exps) = updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty) updateValue s v = return (s, v) - + -- updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v) @@ -201,8 +204,8 @@ renameInModule env imports (Module ss coms mn decls exps) = return (s', TypedBinder t' b') updateBinder s v = return (s, v) - - updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) + -- + updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c) @@ -220,19 +223,19 @@ renameInModule env imports (Module ss coms mn decls exps) = updateType t = return t updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] - updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts) + updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts) updateTypeName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) + updateTypeName = update UnknownType (importedTypes imports) (resolveType . exportedTypes) IsProperName updateDataConstructorName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) + updateDataConstructorName = update (flip UnknownDataConstructor Nothing) (importedDataConstructors imports) (resolveDctor . exportedTypes) DctorName updateClassName :: Qualified ProperName -> Maybe SourceSpan -> m (Qualified ProperName) - updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) + updateClassName = update UnknownTypeClass (importedTypeClasses imports) (resolve . exportedTypeClasses) IsProperName updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) - updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) + updateValueName = update UnknownValue (importedValues imports) (resolve . exportedValues) IdentName -- Used when performing an update to qualify values and classes with their -- module of original definition. @@ -255,16 +258,22 @@ renameInModule env imports (Module ss coms mn decls exps) = update :: (Ord a) => (Qualified a -> SimpleErrorMessage) -> M.Map (Qualified a) (Qualified a, ModuleName) -> (Exports -> a -> Maybe (Qualified a)) + -> (Qualified a -> Name) -> Qualified a -> Maybe SourceSpan -> m (Qualified a) - update unknown imps getE qname@(Qualified mn' name) pos = positioned $ + update unknown imps getE toName qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, -- qualifying with the name of the module it was originally defined in -- rather than the module we're importing from, to handle the case of -- re-exports. - (Just (_, mnOrig), _) -> return $ Qualified (Just mnOrig) name + (Just (qn, mnOrig), _) -> do + case qn of + Qualified (Just mnNew) _ -> + modify $ \result -> M.insert mnNew (maybe [toName qname] (toName qname :) (mnNew `M.lookup` result)) result + _ -> return () + return $ Qualified (Just mnOrig) name -- If the name wasn't found in our imports but was qualified then we need -- to check whether it's a failed import from a "pseudo" module (created -- by qualified importing). If that's not the case, then we just need to diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 192cd5f..7b82792 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -11,7 +11,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,12 +21,13 @@ module Language.PureScript.Sugar.Names.Exports , resolveExports ) where +import Prelude () +import Prelude.Compat + import Data.List (find, intersect) import Data.Maybe (fromMaybe, mapMaybe) +import Data.Foldable (traverse_) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..), (<$>)) -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) @@ -197,7 +197,7 @@ filterModule mn exps refs = do Nothing -> throwError . errorMessage . UnknownExportType $ name Just ((_, dcons), _) -> do let expDcons' = fromMaybe dcons expDcons - mapM_ (checkDcon name dcons) expDcons' + traverse_ (checkDcon name dcons) expDcons' return $ ((name, expDcons'), mn) : result filterTypes _ result _ = return result diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index ab03420..70d61b2 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -11,7 +11,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -19,15 +18,17 @@ module Language.PureScript.Sugar.Names.Imports ( resolveImports , resolveModuleImport + , findImports ) where +import Prelude () +import Prelude.Compat + import Data.List (find) import Data.Maybe (fromMaybe, isNothing) +import Data.Foldable (traverse_) import Control.Arrow (first) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..), (<$>)) -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Writer (MonadWriter(..), censor) @@ -40,8 +41,10 @@ import Language.PureScript.Names import Language.PureScript.Errors import Language.PureScript.Sugar.Names.Env +-- | -- Finds the imports within a module, mapping the imported module name to an optional set of -- explicitly imported declarations. +-- findImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => [Declaration] -> m (M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)]) findImports = foldM (go Nothing) M.empty where @@ -54,7 +57,7 @@ findImports = foldM (go Nothing) M.empty -- Ensure that classes don't appear in an `import X hiding (...)` checkImportRefType :: ImportDeclarationType -> m () - checkImportRefType (Hiding refs) = mapM_ checkImportRef refs + checkImportRefType (Hiding refs) = traverse_ checkImportRef refs checkImportRefType _ = return () checkImportRef :: DeclarationRef -> m () checkImportRef (ModuleRef name) = throwError . errorMessage $ ImportHidingModule name @@ -102,7 +105,7 @@ resolveImport currentModule importModule exps imps impQual = -- Check that a 'DeclarationRef' refers to an importable symbol checkRefs :: [DeclarationRef] -> m () - checkRefs = mapM_ check + checkRefs = traverse_ check where check (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ check r @@ -111,7 +114,7 @@ resolveImport currentModule importModule exps imps impQual = check (TypeRef name dctors) = do checkImportExists UnknownImportType ((fst . fst) `map` exportedTypes exps) name let allDctors = fst `map` allExportedDataConstructors name - maybe (return ()) (mapM_ $ checkDctorExists name allDctors) dctors + maybe (return ()) (traverse_ $ checkDctorExists name allDctors) dctors check (TypeClassRef name) = checkImportExists UnknownImportTypeClass (fst `map` exportedTypeClasses exps) name --check (ModuleRef name) = @@ -155,7 +158,7 @@ resolveImport currentModule importModule exps imps impQual = -- Import something explicitly importExplicit :: Imports -> DeclarationRef -> m Imports importExplicit imp (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r + warnAndRethrowWithPosition pos $ importExplicit imp r importExplicit imp (ValueRef name) = do values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name return $ imp { importedValues = values' } @@ -165,7 +168,7 @@ resolveImport currentModule importModule exps imps impQual = exportedDctors = allExportedDataConstructors name dctorNames :: [ProperName] dctorNames = fst `map` exportedDctors - maybe (return ()) (mapM_ $ checkDctorExists name dctorNames) dctors + maybe (return ()) (traverse_ $ checkDctorExists name dctorNames) dctors when (null dctorNames && isNothing dctors) . tell . errorMessage $ MisleadingEmptyTypeImport importModule name dctors' <- foldM (\m -> updateImports m runProperName exportedDctors) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 6b4f6cd..a68331e 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -14,15 +14,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.ObjectWildcards ( desugarObjectConstructors ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Prelude () +import Prelude.Compat + import Control.Arrow (second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 116c2a0..5934b9f 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -21,7 +21,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.Operators ( rebracket, @@ -29,15 +28,15 @@ module Language.PureScript.Sugar.Operators ( desugarOperatorSections ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names import Language.PureScript.Externs -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Supply.Class @@ -60,14 +59,14 @@ rebracket externs ms = do let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities - mapM (rebracketModule opTable) ms + traverse (rebracketModule opTable) ms removeSignedLiterals :: Module -> Module removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts where (f', _, _) = everywhereOnValues id go id - go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val + go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val go other = other rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module @@ -164,7 +163,7 @@ matchOp op = do guard $ ident == op desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module -desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> mapM goDecl ds <*> pure exts +desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> traverse goDecl ds <*> pure exts where goDecl :: Declaration -> m Declaration diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 97ea9c4..44300e3 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -16,7 +16,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.TypeClasses ( desugarTypeClasses @@ -24,6 +23,9 @@ module Language.PureScript.Sugar.TypeClasses , superClassDictionaryNames ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.Crash import Language.PureScript.AST hiding (isExported) import Language.PureScript.Environment @@ -37,9 +39,6 @@ import Language.PureScript.Types import qualified Language.PureScript.Constants as C -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow (first, second) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State @@ -57,7 +56,7 @@ type Desugar = StateT MemberMap -- instance dictionary expressions. -- desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module] -desugarTypeClasses externs = flip evalStateT initialState . mapM desugarModule +desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule where initialState :: MemberMap initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) @@ -262,7 +261,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys -- Create values for the type instance members - members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls + members <- zip (map typeClassMemberName decls) <$> traverse (memberToValue memberTypes) decls -- Create the type of the dictionary -- The type is an object type, but depending on type instance dependencies, may be constrained. diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index d83d383..08840f6 100644 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -1,233 +1,240 @@ ------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.TypeClasses.Deriving
--- Copyright : (c) Gershom Bazerman 2015
--- License : MIT (http://opensource.org/licenses/MIT)
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module implements the generic deriving elaboration that takes place during desugaring.
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE CPP #-}
-
-module Language.PureScript.Sugar.TypeClasses.Deriving (
- deriveInstances
-) where
-
-import Data.List
-import Data.Maybe (fromMaybe)
-import Data.Ord (comparing)
-
-#if __GLASGOW_HASKELL__ < 710
-import Control.Applicative
-#endif
-import Control.Monad (replicateM)
-import Control.Monad.Supply.Class (MonadSupply, freshName)
-import Control.Monad.Error.Class (MonadError(..))
-
-import Language.PureScript.Crash
-import Language.PureScript.AST
-import Language.PureScript.Environment
-import Language.PureScript.Errors
-import Language.PureScript.Names
-import Language.PureScript.Types
-import qualified Language.PureScript.Constants as C
-
--- | Elaborates deriving instance declarations by code generation.
-deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
-deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
-
--- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
--- elaborates that into an instance declaration via code generation.
-deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
-deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
- | className == Qualified (Just dataGeneric) (ProperName C.generic)
- , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
- , mn == fromMaybe mn mn'
- = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon
-deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
- = throwError . errorMessage $ CannotDerive className tys
-deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
-deriveInstance _ _ e = return e
-
-unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName)
-unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon
-unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty
-unwrapTypeConstructor _ = Nothing
-
-dataGeneric :: ModuleName
-dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
-
-dataMaybe :: ModuleName
-dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
-
-deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]
-deriveGeneric mn ds tyConNm = do
- tyCon <- findTypeDecl tyConNm ds
- toSpine <- mkSpineFunction mn tyCon
- fromSpine <- mkFromSpineFunction mn tyCon
- let toSignature = mkSignatureFunction mn tyCon
- return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
- , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
- , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
- ]
-
-findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration
-findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl
- where
- isTypeDecl :: Declaration -> Bool
- isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True
- isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
- isTypeDecl _ = False
-
-mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
-mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
- where
- prodConstructor :: Expr -> Expr
- prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
-
- recordConstructor :: Expr -> Expr
- recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
-
- mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
- mkCtorClause (ctorName, tys) = do
- idents <- replicateM (length tys) (fmap Ident freshName)
- return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
- where
- caseResult idents =
- App (prodConstructor (StringLiteral . runProperName $ ctorName))
- . ArrayLiteral
- $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
-
- toSpineFun :: Expr -> Type -> Expr
- toSpineFun i r | Just rec <- objectType r =
- lamNull . recordConstructor . ArrayLiteral .
- map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
- $ decomposeRec rec
- toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
-mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
-mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
-
-mkSignatureFunction :: ModuleName -> Declaration -> Expr
-mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
- where
- mkSigProd :: [Expr] -> Expr
- mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
-
- mkSigRec :: [Expr] -> Expr
- mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
-
- proxy :: Type -> Type
- proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))
-
- mkProdClause :: (ProperName, [Type]) -> Expr
- mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
- , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
- ]
-
- mkProductSignature :: Type -> Expr
- mkProductSignature r | Just rec <- objectType r =
- lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
- , ("recValue", mkProductSignature typ)
- ]
- | (str, typ) <- decomposeRec rec
- ]
- mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
- (TypedValue False (mkGenVar "anyProxy") (proxy typ))
-mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
-mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
-
-mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
-mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
- where
- mkJust :: Expr -> Expr
- mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
-
- mkNothing :: Expr
- mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
-
- prodBinder :: [Binder] -> Binder
- prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
-
- recordBinder :: [Binder] -> Binder
- recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
-
- mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
- mkAlternative (ctorName, tys) = do
- idents <- replicateM (length tys) (fmap Ident freshName)
- return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]
- . Right
- $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
- (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)
-
- addCatch :: [CaseAlternative] -> [CaseAlternative]
- addCatch = (++ [catchAll])
- where
- catchAll = CaseAlternative [NullBinder] (Right mkNothing)
-
- fromSpineFun e r
- | Just rec <- objectType r
- = App (lamCase "r" [ mkRecCase (decomposeRec rec)
- , CaseAlternative [NullBinder] (Right mkNothing)
- ])
- (App e (mkPrelVar "unit"))
-
- fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
-
- mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
- ]
- ]
- . Right
- $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
-
- mkRecFun :: [(String, Type)] -> Expr
- mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
- where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
-mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
-mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"
-
--- Helpers
-
-objectType :: Type -> Maybe Type
-objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
-objectType _ = Nothing
-
-lam :: String -> Expr -> Expr
-lam s = Abs (Left (Ident s))
-
-lamNull :: Expr -> Expr
-lamNull = lam "$q"
-
-lamCase :: String -> [CaseAlternative] -> Expr
-lamCase s = lam s . Case [mkVar s]
-
-liftApplicative :: Expr -> [Expr] -> Expr
-liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
-
-mkVarMn :: Maybe ModuleName -> String -> Expr
-mkVarMn mn s = Var (Qualified mn (Ident s))
-
-mkVar :: String -> Expr
-mkVar s = mkVarMn Nothing s
-
-mkPrelVar :: String -> Expr
-mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
-
-mkGenVar :: String -> Expr
-mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s
-
-decomposeRec :: Type -> [(String, Type)]
-decomposeRec = sortBy (comparing fst) . go
- where go (RCons str typ typs) = (str, typ) : decomposeRec typs
- go _ = []
+----------------------------------------------------------------------------- +-- +-- Module : Language.PureScript.Sugar.TypeClasses.Deriving +-- Copyright : (c) Gershom Bazerman 2015 +-- License : MIT (http://opensource.org/licenses/MIT) +-- +-- Maintainer : Phil Freeman <paf31@cantab.net> +-- Stability : experimental +-- Portability : +-- +-- | +-- This module implements the generic deriving elaboration that takes place during desugaring. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.PureScript.Sugar.TypeClasses.Deriving ( + deriveInstances +) where + +import Prelude () +import Prelude.Compat + +import Data.List (foldl', find, sortBy) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) + +import Control.Monad (replicateM) +import Control.Monad.Supply.Class (MonadSupply, freshName) +import Control.Monad.Error.Class (MonadError(..)) + +import Language.PureScript.Crash +import Language.PureScript.AST +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Names +import Language.PureScript.Types +import qualified Language.PureScript.Constants as C + +-- | Elaborates deriving instance declarations by code generation. +deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module +deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts + +-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, +-- elaborates that into an instance declaration via code generation. +deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration +deriveInstance mn 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 +deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) + = throwError . errorMessage $ CannotDerive className tys +deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d +deriveInstance _ _ e = return e + +unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type]) +unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, []) +unwrapTypeConstructor (TypeApp ty arg) = do + (tyCon, args) <- unwrapTypeConstructor ty + return (tyCon, arg : args) +unwrapTypeConstructor _ = Nothing + +dataGeneric :: ModuleName +dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] + +dataMaybe :: ModuleName +dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ] + +typesProxy :: ModuleName +typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ] + +deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration] +deriveGeneric mn ds tyConNm args = do + tyCon <- findTypeDecl tyConNm ds + toSpine <- mkSpineFunction mn tyCon + fromSpine <- mkFromSpineFunction mn tyCon + let toSignature = mkSignatureFunction mn tyCon args + return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine) + , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine) + , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature) + ] + +findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration +findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl + where + isTypeDecl :: Declaration -> Bool + isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True + isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d + isTypeDecl _ = False + +mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr +mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args + where + prodConstructor :: Expr -> Expr + prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd"))) + + recordConstructor :: Expr -> Expr + recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord"))) + + mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative + mkCtorClause (ctorName, tys) = do + idents <- replicateM (length tys) (fmap Ident freshName) + return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) + where + caseResult idents = + App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) + . ArrayLiteral + $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys + + toSpineFun :: Expr -> Type -> Expr + toSpineFun i r | Just rec <- objectType r = + lamNull . recordConstructor . ArrayLiteral . + map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)]) + $ decomposeRec rec + toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i +mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d +mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration" + +mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr +mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args + where + mkSigProd :: [Expr] -> Expr + mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) + (StringLiteral (showQualified runProperName (Qualified (Just mn) name))) + ) . ArrayLiteral + + mkSigRec :: [Expr] -> Expr + mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral + + proxy :: Type -> Type + proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy"))) + + mkProdClause :: (ProperName, [Type]) -> Expr + mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))) + , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys) + ] + + mkProductSignature :: Type -> Expr + mkProductSignature r | Just rec <- objectType r = + lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str) + , ("recValue", mkProductSignature typ) + ] + | (str, typ) <- decomposeRec rec + ] + mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature) + (TypedValue False (mkGenVar "anyProxy") (proxy typ)) + instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) +mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs +mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration" + +mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr +mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args) + where + mkJust :: Expr -> Expr + mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just"))) + + mkNothing :: Expr + mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing")) + + prodBinder :: [Binder] -> Binder + prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd")) + + recordBinder :: [Binder] -> Binder + recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord")) + + mkAlternative :: (ProperName, [Type]) -> m CaseAlternative + mkAlternative (ctorName, tys) = do + idents <- replicateM (length tys) (fmap Ident freshName) + return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]] + . Right + $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName)) + (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys) + + addCatch :: [CaseAlternative] -> [CaseAlternative] + addCatch = (++ [catchAll]) + where + catchAll = CaseAlternative [NullBinder] (Right mkNothing) + + fromSpineFun e r + | Just rec <- objectType r + = App (lamCase "r" [ mkRecCase (decomposeRec rec) + , CaseAlternative [NullBinder] (Right mkNothing) + ]) + (App e (mkPrelVar "unit")) + + fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit")) + + mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs) + ] + ] + . Right + $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs) + + mkRecFun :: [(String, Type)] -> Expr + mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs) + where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs +mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d +mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration" + +-- Helpers + +objectType :: Type -> Maybe Type +objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec +objectType _ = Nothing + +lam :: String -> Expr -> Expr +lam s = Abs (Left (Ident s)) + +lamNull :: Expr -> Expr +lamNull = lam "$q" + +lamCase :: String -> [CaseAlternative] -> Expr +lamCase s = lam s . Case [mkVar s] + +liftApplicative :: Expr -> [Expr] -> Expr +liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e) + +mkVarMn :: Maybe ModuleName -> String -> Expr +mkVarMn mn s = Var (Qualified mn (Ident s)) + +mkVar :: String -> Expr +mkVar = mkVarMn Nothing + +mkPrelVar :: String -> Expr +mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude])) + +mkGenVar :: String -> Expr +mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) + +decomposeRec :: Type -> [(String, Type)] +decomposeRec = sortBy (comparing fst) . go + where go (RCons str typ typs) = (str, typ) : decomposeRec typs + go _ = [] diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index f435e94..8294d82 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -16,15 +16,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Sugar.TypeDeclarations ( desugarTypeDeclarationsModule ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Prelude () +import Prelude.Compat + import Control.Monad (forM) import Control.Monad.Error.Class (MonadError(..)) @@ -62,9 +61,13 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module ss coms name ds exps) -> let (_, f, _) = everywhereOnValuesTopDownM return go return f' (Left gs) = Left <$> mapM (pairM return f) gs f' (Right v) = Right <$> f v - (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest + (:) <$> (ValueDeclaration name nameKind bs <$> f' val) + <*> desugarTypeDeclarations rest where go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val' go other = return other + desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds) : rest) = + (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds) + <*> desugarTypeDeclarations rest desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/Traversals.hs b/src/Language/PureScript/Traversals.hs index 67bb513..7410729 100644 --- a/src/Language/PureScript/Traversals.hs +++ b/src/Language/PureScript/Traversals.hs @@ -12,13 +12,10 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} - module Language.PureScript.Traversals where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Prelude () +import Prelude.Compat fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b) fstM f (a, b) = flip (,) b <$> f a diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 4c41bf3..70a89c8 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -13,14 +13,18 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.TypeChecker ( module T, typeCheckModule ) where +import Prelude () +import Prelude.Compat + import Language.PureScript.TypeChecker.Monad as T import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Types as T @@ -28,15 +32,14 @@ import Language.PureScript.TypeChecker.Synonyms as T import Data.Maybe import Data.List (nub, (\\), sort, group) -import Data.Foldable (for_) +import Data.Foldable (for_, traverse_) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), (<*)) -#endif -import Control.Monad.State +import Control.Monad (when, unless, void, forM, forM_) +import Control.Monad.State.Class (MonadState(..), modify) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) import Language.PureScript.Crash import Language.PureScript.Types @@ -47,44 +50,84 @@ import Language.PureScript.TypeClassDictionaries import Language.PureScript.Environment import Language.PureScript.Errors -addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check () +addDataType :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + DataDeclType -> + ProperName -> + [(String, Maybe Kind)] -> + [(ProperName, [Type])] -> + Kind -> + m () addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) } - forM_ dctors $ \(dctor, tys) -> + for_ dctors $ \(dctor, tys) -> warnAndRethrow (addHint (ErrorInDataConstructor dctor)) $ addDataConstructor moduleName dtype name (map fst args) dctor tys -addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check () +addDataConstructor :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + DataDeclType -> + ProperName -> + [String] -> + ProperName -> + [Type] -> + m () addDataConstructor moduleName dtype name args dctor tys = do env <- getEnv - mapM_ checkTypeSynonyms tys + traverse_ checkTypeSynonyms tys let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args) let dctorTy = foldr function retTy tys let polyType = mkForAll args dctorTy let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]] putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } -addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check () +addTypeSynonym :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + ProperName -> + [(String, Maybe Kind)] -> + Type -> + Kind -> + m () addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env) , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) } -valueIsNotDefined :: ModuleName -> Ident -> Check () +valueIsNotDefined :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + Ident -> + m () valueIsNotDefined moduleName name = do env <- getEnv case M.lookup (moduleName, name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> return () -addValue :: ModuleName -> Ident -> Type -> NameKind -> Check () +addValue :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + Ident -> + Type -> + NameKind -> + m () addValue moduleName name ty nameKind = do env <- getEnv putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) }) -addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Check () +addTypeClass :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + ProperName -> + [(String, Maybe Kind)] -> + [Constraint] -> + [Declaration] -> + m () addTypeClass moduleName pn args implies ds = let members = map toPair ds in modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } } @@ -93,19 +136,30 @@ addTypeClass moduleName pn args implies ds = toPair (PositionedDeclaration _ _ d) = toPair d toPair _ = internalError "Invalid declaration in TypeClassDeclaration" -addTypeClassDictionaries :: Maybe ModuleName -> M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> Check () +addTypeClassDictionaries :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Maybe ModuleName -> + M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope) -> + m () addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } where insertState st = M.insertWith (M.unionWith M.union) mn entries (typeClassDictionaries . checkEnv $ st) -checkDuplicateTypeArguments :: [String] -> Check () +checkDuplicateTypeArguments :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + [String] -> + m () checkDuplicateTypeArguments args = for_ firstDup $ \dup -> throwError . errorMessage $ DuplicateTypeArgument dup where firstDup :: Maybe String firstDup = listToMaybe $ args \\ nub args -checkTypeClassInstance :: ModuleName -> Type -> Check () +checkTypeClassInstance :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + Type -> + m () checkTypeClassInstance _ (TypeVar _) = return () checkTypeClassInstance _ (TypeConstructor ctor) = do env <- getEnv @@ -117,7 +171,10 @@ checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty -- | -- Check that type synonyms are fully-applied in a type -- -checkTypeSynonyms :: Type -> Check () +checkTypeSynonyms :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Type -> + m () checkTypeSynonyms = void . replaceAllTypeSynonyms -- | @@ -133,10 +190,15 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms -- -- * Process module imports -- -typeCheckAll :: ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration] -typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds +typeCheckAll :: forall m. + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + [DeclarationRef] -> + [Declaration] -> + m [Declaration] +typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkOrphanFixities ds where - go :: Declaration -> Check Declaration + go :: Declaration -> m Declaration go (DataDeclaration dtype name args dctors) = do warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do when (dtype == Newtype) $ checkNewtype dctors @@ -146,7 +208,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds addDataType moduleName dtype name args' dctors ctorKind return $ DataDeclaration dtype name args dctors where - checkNewtype :: [(ProperName, [Type])] -> Check () + checkNewtype :: [(ProperName, [Type])] -> m () checkNewtype [(_, [_])] = return () checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype name checkNewtype _ = throwError . errorMessage $ InvalidNewtype name @@ -155,11 +217,11 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds let syns = mapMaybe toTypeSynonym tys let dataDecls = mapMaybe toDataDecl tys (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) - forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do + for_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind - forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do + for_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do checkDuplicateTypeArguments $ map fst args let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind @@ -188,7 +250,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds go (ValueDeclaration{}) = internalError "Binders were not desugared" go (BindingGroupDeclaration vals) = warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do - forM_ (map (\(ident, _, _) -> ident) vals) $ \name -> + for_ (map (\(ident, _, _) -> ident) vals) $ \name -> valueIsNotDefined moduleName name tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals vals' <- forM [ (name, val, nameKind, ty) @@ -218,8 +280,8 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds addTypeClass moduleName pn args implies tys return d go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do - mapM_ (checkTypeClassInstance moduleName) tys - forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd + traverse_ (checkTypeClassInstance moduleName) tys + forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd checkOrphanInstance dictName className tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) @@ -228,7 +290,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds go (PositionedDeclaration pos com d) = warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d - checkOrphanFixities :: Declaration -> Check () + checkOrphanFixities :: Declaration -> m () checkOrphanFixities (FixityDeclaration _ name) = do env <- getEnv guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env @@ -236,7 +298,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds warnAndRethrowWithPosition pos $ checkOrphanFixities d checkOrphanFixities _ = return () - checkInstanceMembers :: [Declaration] -> Check [Declaration] + checkInstanceMembers :: [Declaration] -> m [Declaration] checkInstanceMembers instDecls = do let idents = sort . map head . group . map memberName $ instDecls for_ (firstDuplicate idents) $ \ident -> @@ -254,7 +316,7 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds | otherwise = firstDuplicate xs firstDuplicate _ = Nothing - checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> Check () + checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> m () checkOrphanInstance dictName className@(Qualified (Just mn') _) tys' | moduleName == mn' || any checkType tys' = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' @@ -281,19 +343,22 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds -- Type check an entire module and ensure all types and classes defined within the module that are -- required by exported members are also exported. -- -typeCheckModule :: Module -> Check Module +typeCheckModule :: forall m. + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Module -> + m Module typeCheckModule (Module _ _ _ _ Nothing) = internalError "exports should have been elaborated" typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint (ErrorInModule mn)) $ do modify (\s -> s { checkCurrentModule = Just mn }) decls' <- typeCheckAll mn exps decls - forM_ exps $ \e -> do + for_ exps $ \e -> do checkTypesAreExported e checkClassMembersAreExported e checkClassesAreExported e return $ Module ss coms mn decls' (Just exps) where - checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check () + checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () checkMemberExport extract dr@(TypeRef name dctors) = do env <- getEnv case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of @@ -301,7 +366,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint Just (_, ty) -> checkExport dr extract ty case dctors of Nothing -> return () - Just dctors' -> forM_ dctors' $ \dctor -> + Just dctors' -> for_ dctors' $ \dctor -> case M.lookup (Qualified (Just mn) dctor) (dataConstructors env) of Nothing -> return () Just (_, _, ty, _) -> checkExport dr extract ty @@ -311,7 +376,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint checkExport dr extract ty checkMemberExport _ _ = return () - checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> Check () + checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m () checkExport dr extract ty = case filter (not . exported) (extract ty) of [] -> return () hidden -> throwError . errorMessage $ TransitiveExportError dr hidden @@ -326,7 +391,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint -- Check that all the type constructors defined in the current module that appear in member types -- have also been exported from the module - checkTypesAreExported :: DeclarationRef -> Check () + checkTypesAreExported :: DeclarationRef -> m () checkTypesAreExported = checkMemberExport findTcons where findTcons :: Type -> [DeclarationRef] @@ -337,7 +402,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint -- Check that all the classes defined in the current module that appear in member types have also -- been exported from the module - checkClassesAreExported :: DeclarationRef -> Check () + checkClassesAreExported :: DeclarationRef -> m () checkClassesAreExported = checkMemberExport findClasses where findClasses :: Type -> [DeclarationRef] @@ -349,7 +414,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name extractCurrentModuleClass _ = Nothing - checkClassMembersAreExported :: DeclarationRef -> Check () + checkClassMembersAreExported :: DeclarationRef -> m () checkClassMembersAreExported dr@(TypeClassRef name) = do let members = ValueRef `map` head (mapMaybe findClassMembers decls) let missingMembers = members \\ exps diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 3bc4f30..c290f0f 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -13,33 +13,30 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.TypeChecker.Entailment ( entails ) where +import Prelude () +import Prelude.Compat + import Data.Function (on) -import Data.List +import Data.List (minimumBy, sortBy, groupBy) import Data.Maybe (maybeToList, mapMaybe) -#if __GLASGOW_HASKELL__ < 710 -import Data.Foldable (foldMap) -#endif import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow (Arrow(..)) import Control.Monad.State import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (tell) +import Control.Monad.Writer.Class (MonadWriter(..)) import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types @@ -49,7 +46,12 @@ import qualified Language.PureScript.Constants as C -- Check that the current set of type class dictionaries entail the specified type class goal, and, if so, -- return a type class dictionary reference. -- -entails :: ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr +entails :: forall m. + (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> + Constraint -> + m Expr entails moduleName context = solve where forClassName :: Qualified ProperName -> [Type] -> [TypeClassDictionaryInScope] @@ -65,12 +67,12 @@ entails moduleName context = solve findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope] findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context - solve :: Constraint -> Check Expr + solve :: Constraint -> m Expr solve (className, tys) = do dict <- go 0 className tys return $ dictionaryValueToValue dict where - go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue + go :: Int -> Qualified ProperName -> [Type] -> m DictionaryValue go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys' go work className' tys' = do let instances = do @@ -86,7 +88,7 @@ entails moduleName context = solve (tcdPath tcd) where - unique :: [(a, TypeClassDictionaryInScope)] -> Check (a, TypeClassDictionaryInScope) + unique :: [(a, TypeClassDictionaryInScope)] -> m (a, TypeClassDictionaryInScope) unique [] = throwError . errorMessage $ NoInstanceFound className' tys' unique [a] = return a unique tcds | pairwise overlapping (map snd tcds) = do @@ -109,10 +111,10 @@ entails moduleName context = solve -- Create dictionaries for subgoals which still need to be solved by calling go recursively -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively. - solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> Check (Maybe [DictionaryValue]) + solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> m (Maybe [DictionaryValue]) solveSubgoals _ Nothing = return Nothing solveSubgoals subst (Just subgoals) = do - dict <- mapM (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals + dict <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals return $ Just dict -- Make a dictionary from subgoal dictionaries by applying the correct function diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index e0aa8cf..37872f2 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -13,11 +13,12 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} module Language.PureScript.TypeChecker.Kinds ( kindOf, @@ -26,19 +27,16 @@ module Language.PureScript.TypeChecker.Kinds ( kindsOfAll ) where -import Data.Maybe (fromMaybe) +import Prelude () +import Prelude.Compat -import qualified Data.HashMap.Strict as H import qualified Data.Map as M import Control.Arrow (second) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.State -import Control.Monad.Unify import Language.PureScript.Crash import Language.PureScript.Environment @@ -48,177 +46,213 @@ import Language.PureScript.Names import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types -instance Partial Kind where - unknown = KUnknown - isUnknown (KUnknown u) = Just u - isUnknown _ = Nothing - unknowns = everythingOnKinds (++) go - where - go (KUnknown u) = [u] - go _ = [] - ($?) sub = everywhereOnKinds go - where - go t@(KUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub) - go other = other - -instance Unifiable Check Kind where - KUnknown u1 =?= KUnknown u2 | u1 == u2 = return () - KUnknown u =?= k = u =:= k - k =?= KUnknown u = u =:= k - Star =?= Star = return () - Bang =?= Bang = return () - Row k1 =?= Row k2 = k1 =?= k2 - FunKind k1 k2 =?= FunKind k3 k4 = do - k1 =?= k3 - k2 =?= k4 - k1 =?= k2 = UnifyT . lift . throwError . errorMessage $ KindsDoNotUnify k1 k2 +-- | Generate a fresh kind variable +freshKind :: (MonadState CheckState m) => m Kind +freshKind = do + k <- gets checkNextKind + modify $ \st -> st { checkNextKind = k + 1 } + return $ KUnknown k --- | --- Infer the kind of a single type --- -kindOf :: Type -> Check Kind +-- | Update the substitution to solve a kind constraint +solveKind :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Kind -> m () +solveKind u k = do + occursCheck u k + modify $ \cs -> cs { checkSubstitution = + (checkSubstitution cs) { substKind = + M.insert u k $ substKind $ checkSubstitution cs + } + } + +-- | Apply a substitution to a kind +substituteKind :: Substitution -> Kind -> Kind +substituteKind sub = everywhereOnKinds go + where + go (KUnknown u) = + case M.lookup u (substKind sub) of + Nothing -> KUnknown u + Just (KUnknown u1) | u1 == u -> KUnknown u1 + Just t -> substituteKind sub t + go other = other + +-- | Make sure that an unknown does not occur in a kind +occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Kind -> m () +occursCheck _ KUnknown{} = return () +occursCheck u k = void $ everywhereOnKindsM go k + where + go (KUnknown u') | u == u' = throwError . errorMessage . InfiniteKind $ k + go other = return other + +-- | Unify two kinds +unifyKinds :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Kind -> Kind -> m () +unifyKinds k1 k2 = do + sub <- gets checkSubstitution + go (substituteKind sub k1) (substituteKind sub k2) + where + 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 (Row k1') (Row k2') = go k1' k2' + go (FunKind k1' k2') (FunKind k3 k4) = do + go k1' k3 + go k2' k4 + go k1' k2' = throwError . errorMessage $ KindsDoNotUnify k1' k2' + +-- | Infer the kind of a single type +kindOf :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + Type -> + m Kind kindOf ty = fst <$> kindOfWithScopedVars ty --- | --- Infer the kind of a single type, returning the kinds of any scoped type variables --- -kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)]) +-- | Infer the kind of a single type, returning the kinds of any scoped type variables +kindOfWithScopedVars :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + Type -> + m (Kind, [(String, Kind)]) kindOfWithScopedVars ty = rethrow (addHint (ErrorCheckingKind ty)) $ fmap tidyUp . liftUnify $ infer ty where - tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k) - , map (second (starIfUnknown . (sub $?))) args + tidyUp ((k, args), sub) = ( starIfUnknown (substituteKind sub k) + , map (second (starIfUnknown . substituteKind sub)) args ) --- | --- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors --- -kindsOf :: Bool -> ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Type] -> Check Kind +-- | Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors +kindsOf :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + Bool -> + ModuleName -> + ProperName -> + [(String, Maybe Kind)] -> + [Type] -> + m Kind kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do - tyCon <- fresh - kargs <- replicateM (length args) fresh + tyCon <- freshKind + kargs <- replicateM (length args) freshKind rest <- zipWithM freshKindVar args kargs let dict = (name, tyCon) : rest bindLocalTypeVariables moduleName dict $ solveTypes isData ts kargs tyCon where - tidyUp (k, sub) = starIfUnknown $ sub $? k + tidyUp (k, sub) = starIfUnknown $ substituteKind sub k -freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind) +freshKindVar :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => + (String, Maybe Kind) -> + Kind -> + m (ProperName, Kind) freshKindVar (arg, Nothing) kind = return (ProperName arg, kind) freshKindVar (arg, Just kind') kind = do - kind =?= kind' + unifyKinds kind kind' return (ProperName arg, kind') --- | --- Simultaneously infer the kinds of several mutually recursive type constructors --- -kindsOfAll :: ModuleName -> [(ProperName, [(String, Maybe Kind)], Type)] -> [(ProperName, [(String, Maybe Kind)], [Type])] -> Check ([Kind], [Kind]) +-- | Simultaneously infer the kinds of several mutually recursive type constructors +kindsOfAll :: + (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m, MonadWriter MultipleErrors m) => + ModuleName -> + [(ProperName, [(String, Maybe Kind)], Type)] -> + [(ProperName, [(String, Maybe Kind)], [Type])] -> + m ([Kind], [Kind]) kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do - synVars <- replicateM (length syns) fresh + synVars <- replicateM (length syns) freshKind let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars bindLocalTypeVariables moduleName dict $ do - tyCons <- replicateM (length tys) fresh + tyCons <- replicateM (length tys) freshKind let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons bindLocalTypeVariables moduleName dict' $ do data_ks <- zipWithM (\tyCon (_, args, ts) -> do - kargs <- replicateM (length args) fresh + kargs <- replicateM (length args) freshKind argDict <- zipWithM freshKindVar args kargs bindLocalTypeVariables moduleName argDict $ solveTypes True ts kargs tyCon) tyCons tys syn_ks <- zipWithM (\synVar (_, args, ty) -> do - kargs <- replicateM (length args) fresh + kargs <- replicateM (length args) freshKind argDict <- zipWithM freshKindVar args kargs bindLocalTypeVariables moduleName argDict $ solveTypes False [ty] kargs synVar) synVars syns return (syn_ks, data_ks) where - tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . (sub $?)) ks1, map (starIfUnknown . (sub $?)) ks2) + tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . substituteKind sub) ks1, map (starIfUnknown . substituteKind sub) ks2) --- | --- Solve the set of kind constraints associated with the data constructors for a type constructor --- -solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind +-- | Solve the set of kind constraints associated with the data constructors for a type constructor +solveTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Bool -> [Type] -> [Kind] -> Kind -> m Kind solveTypes isData ts kargs tyCon = do - ks <- mapM (fmap fst . infer) ts + ks <- traverse (fmap fst . infer) ts when isData $ do - tyCon =?= foldr FunKind Star kargs - forM_ ks $ \k -> k =?= Star + unifyKinds tyCon (foldr FunKind Star kargs) + forM_ ks $ \k -> unifyKinds k Star unless isData $ - tyCon =?= foldr FunKind (head ks) kargs + 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 Star kind of types starIfUnknown :: Kind -> Kind starIfUnknown (KUnknown _) = Star starIfUnknown (Row k) = Row (starIfUnknown k) starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k --- | --- Infer a kind for a type --- -infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) +-- | Infer a kind for a type +infer :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) infer ty = rethrow (addHint (ErrorCheckingKind ty)) $ infer' ty -infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)]) +infer' :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> m (Kind, [(String, Kind)]) infer' (ForAll ident ty _) = do - k1 <- fresh + k1 <- freshKind Just moduleName <- checkCurrentModule <$> get (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty - k2 =?= Star + unifyKinds k2 Star return (Star, (ident, k1) : args) infer' (KindedType ty k) = do (k', args) <- infer ty - k =?= k' + unifyKinds k k' return (k', args) infer' other = (, []) <$> go other where - go :: Type -> UnifyT Kind Check Kind + go :: Type -> m Kind go (ForAll ident ty _) = do - k1 <- fresh + k1 <- freshKind Just moduleName <- checkCurrentModule <$> get k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty - k2 =?= Star + unifyKinds k2 Star return Star go (KindedType ty k) = do k' <- go ty - k =?= k' + unifyKinds k k' return k' - go TypeWildcard = fresh + go TypeWildcard = freshKind go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get - UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) + lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) go (Skolem v _ _) = do Just moduleName <- checkCurrentModule <$> get - UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) + lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) go (TypeConstructor v) = do - env <- liftCheck getEnv + env <- getEnv case M.lookup v (types env) of - Nothing -> UnifyT . lift . throwError . errorMessage $ UnknownTypeConstructor v + Nothing -> throwError . errorMessage $ UnknownTypeConstructor v Just (kind, _) -> return kind go (TypeApp t1 t2) = do - k0 <- fresh + k0 <- freshKind k1 <- go t1 k2 <- go t2 - k1 =?= FunKind k2 k0 + unifyKinds k1 (FunKind k2 k0) return k0 go REmpty = do - k <- fresh + k <- freshKind return $ Row k go (RCons _ ty row) = do k1 <- go ty k2 <- go row - k2 =?= Row k1 + unifyKinds k2 (Row k1) return $ Row k1 go (ConstrainedType deps ty) = do forM_ deps $ \(className, tys) -> do k <- go $ foldl TypeApp (TypeConstructor className) tys - k =?= Star + unifyKinds k Star k <- go ty - k =?= Star + unifyKinds k Star return Star go _ = internalError "Invalid argument to infer" diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 33a791e..97eea4c 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -19,21 +19,19 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Monad where +import Prelude () +import Prelude.Compat + import Data.Maybe import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Control.Arrow (second) import Control.Monad.State -import Control.Monad.Unify -import Control.Monad.Writer.Strict import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Trans.Except +import Control.Monad.Writer.Class (MonadWriter(..), listen, censor) import Language.PureScript.Environment import Language.PureScript.Errors @@ -42,9 +40,36 @@ import Language.PureScript.Names import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types --- | --- Temporarily bind a collection of names to values --- +-- | A substitution of unification variables for types or kinds +data Substitution = Substitution + { substType :: M.Map Int Type -- ^ Type substitution + , substKind :: M.Map Int Kind -- ^ Kind substitution + } + +-- | An empty substitution +emptySubstitution :: Substitution +emptySubstitution = Substitution M.empty M.empty + +-- | State required for type checking +data CheckState = CheckState + { checkEnv :: Environment -- ^ The current @Environment@ + , checkNextType :: Int -- ^ The next type unification variable + , checkNextKind :: Int -- ^ The next kind unification variable + , checkNextSkolem :: Int -- ^ The next skolem variable + , checkNextSkolemScope :: Int -- ^ The next skolem scope constant + , checkNextDictName :: Int -- ^ The next type class dictionary name + , checkCurrentModule :: Maybe ModuleName -- ^ The current module + , checkSubstitution :: Substitution -- ^ The current substitution + } + +-- | Create an empty @CheckState@ +emptyCheckState :: Environment -> CheckState +emptyCheckState env = CheckState env 0 0 0 0 0 Nothing emptySubstitution + +-- | Unification variables +type Unknown = Int + +-- | Temporarily bind a collection of names to values bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a bindNames newNames action = do orig <- get @@ -53,9 +78,7 @@ bindNames newNames action = do modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } } return a --- | --- Temporarily bind a collection of names to types --- +-- | Temporarily bind a collection of names to types bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a bindTypes newNames action = do orig <- get @@ -64,15 +87,16 @@ bindTypes newNames action = do modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } } return a --- | --- Temporarily bind a collection of names to types --- -withScopedTypeVars :: (Functor m, MonadState CheckState m) => ModuleName -> [(String, Kind)] -> m a -> m a -withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) +-- | Temporarily bind a collection of names to types +withScopedTypeVars :: (Functor m, Applicative m, MonadState CheckState m, MonadWriter MultipleErrors m) => ModuleName -> [(String, Kind)] -> m a -> m a +withScopedTypeVars mn ks ma = do + orig <- get + forM_ ks $ \(name, _) -> + when (Qualified (Just mn) (ProperName name) `M.member` types (checkEnv orig)) $ + tell . errorMessage $ ShadowedTypeVar name + bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma --- | --- Temporarily make a collection of type class dictionaries available --- +-- | Temporarily make a collection of type class dictionaries available withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a withTypeClassDictionaries entries action = do orig <- get @@ -82,35 +106,30 @@ withTypeClassDictionaries entries action = do modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } } return a --- | --- Get the currently available map of type class dictionaries --- -getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) +-- | Get the currently available map of type class dictionaries +getTypeClassDictionaries :: + (Functor m, MonadState CheckState m) => + m (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))) getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get --- | --- Lookup type class dictionaries in a module. --- -lookupTypeClassDictionaries :: (Functor m, MonadState CheckState m) => Maybe ModuleName -> m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) +-- | Lookup type class dictionaries in a module. +lookupTypeClassDictionaries :: + (Functor m, MonadState CheckState m) => + Maybe ModuleName -> + m (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) lookupTypeClassDictionaries mn = fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv <$> get --- | --- Temporarily bind a collection of names to local variables --- +-- | Temporarily bind a collection of names to local variables bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a bindLocalVariables moduleName bindings = bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, Private, visibility))) --- | --- Temporarily bind a collection of names to local type variables --- +-- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a bindLocalTypeVariables moduleName bindings = bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable))) --- | --- Update the visibility of all names to Defined --- +-- | Update the visibility of all names to Defined makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m () makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) } @@ -126,9 +145,7 @@ preservingNames action = do modifyEnv $ \e -> e { names = orig } return a --- | --- Lookup the type of a value by name in the @Environment@ --- +-- | Lookup the type of a value by name in the @Environment@ lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type lookupVariable currentModule (Qualified moduleName var) = do env <- getEnv @@ -136,9 +153,7 @@ lookupVariable currentModule (Qualified moduleName var) = do Nothing -> throwError . errorMessage $ NameIsUndefined var Just (ty, _, _) -> return ty --- | --- Lookup the visibility of a value by name in the @Environment@ --- +-- | Lookup the visibility of a value by name in the @Environment@ getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility getVisibility currentModule (Qualified moduleName var) = do env <- getEnv @@ -146,9 +161,7 @@ getVisibility currentModule (Qualified moduleName var) = do Nothing -> throwError . errorMessage $ NameIsUndefined var Just (_, _, vis) -> return vis --- | --- Assert that a name is visible --- +-- | Assert that a name is visible checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m () checkVisibility currentModule name@(Qualified _ var) = do vis <- getVisibility currentModule name @@ -156,9 +169,7 @@ checkVisibility currentModule name@(Qualified _ var) = do Undefined -> throwError . errorMessage $ CycleInDeclaration var _ -> return () --- | --- Lookup the kind of a type by name in the @Environment@ --- +-- | Lookup the kind of a type by name in the @Environment@ lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind lookupTypeVariable currentModule (Qualified moduleName name) = do env <- getEnv @@ -166,113 +177,56 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do Nothing -> throwError . errorMessage $ UndefinedTypeVariable name Just (k, _) -> return k --- | --- State required for type checking: --- -data CheckState = CheckState { - -- | - -- The current @Environment@ - -- - checkEnv :: Environment - -- | - -- The next fresh unification variable name - -- - , checkNextVar :: Int - -- | - -- The next type class dictionary name - -- - , checkNextDictName :: Int - -- | - -- The current module - -- - , checkCurrentModule :: Maybe ModuleName - } - --- | --- The type checking monad, which provides the state of the type checker, and error reporting capabilities --- -newtype Check a = Check { unCheck :: StateT CheckState (ExceptT MultipleErrors (Writer MultipleErrors)) a } - deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors, MonadWriter MultipleErrors) - --- | --- Get the current @Environment@ --- +-- | Get the current @Environment@ getEnv :: (Functor m, MonadState CheckState m) => m Environment getEnv = checkEnv <$> get --- | --- Update the @Environment@ --- +-- | Update the @Environment@ putEnv :: (MonadState CheckState m) => Environment -> m () putEnv env = modify (\s -> s { checkEnv = env }) --- | --- Modify the @Environment@ --- +-- | Modify the @Environment@ modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m () modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) --- | --- Run a computation in the Check monad, starting with an empty @Environment@ --- -runCheck :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Check a -> m (a, Environment) +-- | Run a computation in the typechecking monad, starting with an empty @Environment@ +runCheck :: (Functor m) => StateT CheckState m a -> m (a, Environment) runCheck = runCheck' initEnvironment --- | --- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@. --- -runCheck' :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Environment -> Check a -> m (a, Environment) -runCheck' env = interpretMultipleErrorsAndWarnings . unwrapCheckWithWarnings env - where - unwrapCheckWithWarnings :: Environment -> Check a -> (Either MultipleErrors (a, Environment), MultipleErrors) - unwrapCheckWithWarnings e = - (\(rc, w) -> (envCheck rc, w)) - . runWriter - . runExceptT - . flip runStateT (CheckState e 0 0 Nothing) - . unCheck - envCheck :: Either MultipleErrors (a, CheckState) -> Either MultipleErrors (a, Environment) - envCheck rc = do - (a, s) <- rc - return (a, checkEnv s) +-- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@. +runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment) +runCheck' env check = fmap (second checkEnv) $ runStateT check (emptyCheckState env) --- | --- Make an assertion, failing with an error message --- +-- | Make an assertion, failing with an error message guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e --- | --- Generate new type class dictionary name --- -freshDictionaryName :: Check Int +-- | Generate new type class dictionary name +freshDictionaryName :: (Functor m, MonadState CheckState m) => m Int freshDictionaryName = do n <- checkNextDictName <$> get modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) } return n --- | --- Lift a computation in the @Check@ monad into the substitution monad. --- -liftCheck :: Check a -> UnifyT t Check a -liftCheck = UnifyT . lift - --- | --- Run a computation in the substitution monad, generating a return value and the final substitution. --- -liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t) +-- | Run a computation in the substitution monad, generating a return value and the final substitution. +liftUnify :: + (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => + m a -> + m (a, Substitution) liftUnify = liftUnifyWarnings (const id) --- | --- Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values. --- -liftUnifyWarnings :: (Partial t) => (Substitution t -> ErrorMessage -> ErrorMessage) -> UnifyT t Check a -> Check (a, Substitution t) -liftUnifyWarnings replace unify = do - st <- get - let ru = runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify - ((a, ust), w) <- censor (const mempty) . listen $ ru - modify $ \st' -> st' { checkNextVar = unifyNextVar ust } - let uust = unifyCurrentSubstitution ust - tell $ onErrorMessages (replace uust) w - return (a, uust) +-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values. +liftUnifyWarnings :: + (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) => + (Substitution -> ErrorMessage -> ErrorMessage) -> + m a -> + m (a, Substitution) +liftUnifyWarnings replace ma = do + orig <- get + modify $ \st -> st { checkSubstitution = emptySubstitution } + (a, w) <- reflectErrors . censor (const mempty) . reifyErrors . listen $ ma + subst <- gets checkSubstitution + tell . onErrorMessages (replace subst) $ w + modify $ \st -> st { checkSubstitution = checkSubstitution orig } + return (a, subst) diff --git a/src/Language/PureScript/TypeChecker/Rows.hs b/src/Language/PureScript/TypeChecker/Rows.hs index 1b16e10..bf10f36 100644 --- a/src/Language/PureScript/TypeChecker/Rows.hs +++ b/src/Language/PureScript/TypeChecker/Rows.hs @@ -13,38 +13,44 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} + module Language.PureScript.TypeChecker.Rows ( checkDuplicateLabels ) where import Data.List +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif import Control.Monad import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..)) import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types --- | --- Ensure rows do not contain duplicate labels --- -checkDuplicateLabels :: Expr -> Check () +-- | Ensure rows do not contain duplicate labels +checkDuplicateLabels :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m () checkDuplicateLabels = let (_, f, _) = everywhereOnValuesM def go def in void . f where - def :: a -> Check a + def :: a -> m a def = return - go :: Expr -> Check Expr + go :: Expr -> m Expr go e@(TypedValue _ val ty) = do checkDups ty return e where - checkDups :: Type -> Check () + checkDups :: Type -> m () checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2 checkDups (ForAll _ t _) = checkDups t checkDups (ConstrainedType args t) = do diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs index d1ab4c5..a5c0514 100644 --- a/src/Language/PureScript/TypeChecker/Skolems.hs +++ b/src/Language/PureScript/TypeChecker/Skolems.hs @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module Language.PureScript.TypeChecker.Skolems ( newSkolemConstant, @@ -24,31 +24,36 @@ module Language.PureScript.TypeChecker.Skolems ( skolemEscapeCheck ) where +import Prelude () +import Prelude.Compat + import Data.List (nub, (\\)) import Data.Monoid +import Data.Functor.Identity (Identity(), runIdentity) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Unify +import Control.Monad.State.Class (MonadState(..), gets, modify) import Language.PureScript.Crash import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.TypeChecker.Monad import Language.PureScript.Types +import Language.PureScript.Traversals (defS) -- | -- Generate a new skolem constant -- -newSkolemConstant :: UnifyT Type Check Int -newSkolemConstant = fresh' +newSkolemConstant :: (MonadState CheckState m) => m Int +newSkolemConstant = do + s <- gets checkNextSkolem + modify $ \st -> st { checkNextSkolem = s + 1 } + return s -- | -- Introduce skolem scope at every occurence of a ForAll -- -introduceSkolemScope :: Type -> UnifyT Type Check Type +introduceSkolemScope :: (Functor m, Applicative m, MonadState CheckState m) => Type -> m Type introduceSkolemScope = everywhereOnTypesM go where go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope) @@ -57,8 +62,11 @@ introduceSkolemScope = everywhereOnTypesM go -- | -- Generate a new skolem scope -- -newSkolemScope :: UnifyT Type Check SkolemScope -newSkolemScope = SkolemScope <$> fresh' +newSkolemScope :: (MonadState CheckState m) => m SkolemScope +newSkolemScope = do + s <- gets checkNextSkolemScope + modify $ \st -> st { checkNextSkolemScope = s + 1 } + return $ SkolemScope s -- | -- Skolemize a type variable by replacing its instances with fresh skolem constants @@ -72,21 +80,31 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope) -- only example of scoped type variables. -- skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr -skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id onExpr onBinder in f +skolemizeTypesInValue ident sko scope = + let + (_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS + in runIdentity . f where - onExpr :: Expr -> Expr - onExpr (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts) - onExpr (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty) - onExpr other = other + onExpr :: [String] -> Expr -> Identity ([String], Expr) + onExpr sco (SuperClassDictionary c ts) + | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope) ts)) + onExpr sco (TypedValue check val ty) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ty)) + onExpr sco other = return (sco, other) + + onBinder :: [String] -> Binder -> Identity ([String], Binder) + onBinder sco (TypedBinder ty b) + | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ty) b) + onBinder sco other = return (sco, other) - onBinder :: Binder -> Binder - onBinder (TypedBinder ty b) = TypedBinder (skolemize ident sko scope ty) b - onBinder other = other + peelTypeVars :: Type -> [String] + peelTypeVars (ForAll i ty _) = i : peelTypeVars ty + peelTypeVars _ = [] -- | -- Ensure skolem variables do not escape their scope -- -skolemEscapeCheck :: Expr -> Check () +skolemEscapeCheck :: (MonadError MultipleErrors m, MonadState CheckState m) => Expr -> m () skolemEscapeCheck (TypedValue False _ _) = return () skolemEscapeCheck root@TypedValue{} = -- Every skolem variable is created when a ForAll type is skolemized. diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 9acf9b6..7e4d9af 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -13,6 +13,9 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} + module Language.PureScript.TypeChecker.Subsumption ( subsumes ) where @@ -20,8 +23,11 @@ module Language.PureScript.TypeChecker.Subsumption ( import Data.List (sortBy) import Data.Ord (comparing) -import Control.Monad.Unify -import Control.Monad.Error.Class (throwError) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State.Class (MonadState(..)) import Language.PureScript.Crash import Language.PureScript.AST @@ -32,16 +38,16 @@ import Language.PureScript.TypeChecker.Skolems import Language.PureScript.TypeChecker.Unify import Language.PureScript.Types --- | --- Check whether one type subsumes another, rethrowing errors to provide a better error message --- -subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr) +-- | Check that one type subsumes another, rethrowing errors to provide a better error message +subsumes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Maybe Expr -> Type -> Type -> m (Maybe Expr) subsumes val ty1 ty2 = rethrow (addHint (ErrorInSubsumption ty1 ty2)) $ subsumes' val ty1 ty2 --- | --- Check whether one type subsumes another --- -subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr) +-- | Check tahat one type subsumes another +subsumes' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => + Maybe Expr -> + Type -> + Type -> + m (Maybe Expr) subsumes' val (ForAll ident ty1 _) ty2 = do replaced <- replaceVarWithUnknown ident ty1 subsumes val replaced ty2 @@ -72,25 +78,25 @@ subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject go ts1' ts2' r1' r2' return val where - go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2') - go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1') + go [] ts2 r1' r2' = unifyTypes r1' (rowFromList (ts2, r2')) + go ts1 [] r1' r2' = unifyTypes r2' (rowFromList (ts1, r1')) go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2' | p1 == p2 = do _ <- subsumes Nothing ty1 ty2 go ts1 ts2 r1' r2' - | p1 < p2 = do rest <- fresh + | p1 < p2 = do rest <- freshType -- What happens next is a bit of a hack. -- TODO: in the new type checker, object properties will probably be restricted to being monotypes -- in which case, this branch of the subsumes function should not even be necessary. case r2' of REmpty -> throwError . errorMessage $ AdditionalProperty p1 - _ -> r2' =?= RCons p1 ty1 rest + _ -> unifyTypes r2' (RCons p1 ty1 rest) go ts1 ((p2, ty2) : ts2) r1' rest - | otherwise = do rest <- fresh + | otherwise = do rest <- freshType case r1' of REmpty -> throwError . errorMessage $ PropertyIsMissing p2 - _ -> r1' =?= RCons p2 ty2 rest + _ -> unifyTypes r1' (RCons p2 ty2 rest) go ((p1, ty1) : ts1) ts2 rest r2' subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1 subsumes' val ty1 ty2 = do - ty1 =?= ty2 + unifyTypes ty1 ty2 return val diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 0796665..ae85eee 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -17,18 +17,17 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Synonyms ( replaceAllTypeSynonyms ) where +import Prelude () +import Prelude.Compat + import Data.Maybe (fromMaybe) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index fc8b616..ef4d4e1 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -14,9 +14,9 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Types ( typesOf @@ -38,19 +38,18 @@ module Language.PureScript.TypeChecker.Types ( Check a function of a given type returns a value of another type when applied to its arguments -} +import Prelude () +import Prelude.Compat + import Data.Either (lefts, rights) -import Data.List +import Data.List (transpose, nub, (\\), partition, delete) import Data.Maybe (fromMaybe) import qualified Data.Map as M -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad -import Control.Monad.State -import Control.Monad.Unify +import Control.Monad.State.Class (MonadState(..), gets) import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Writer.Class (tell) +import Control.Monad.Writer.Class (MonadWriter(..)) import Language.PureScript.Crash import Language.PureScript.AST @@ -70,11 +69,13 @@ import Language.PureScript.TypeChecker.Unify import Language.PureScript.TypeClassDictionaries import Language.PureScript.Types --- | --- Infer the types of multiple mutually-recursive values, and return elaborated values including +-- | Infer the types of multiple mutually-recursive values, and return elaborated values including -- type class dictionaries and type annotations. --- -typesOf :: ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))] +typesOf :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + [(Ident, Expr)] -> + m [(Ident, (Expr, Type))] typesOf moduleName vals = do tys <- fmap tidyUp . liftUnifyWarnings replace $ do (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals @@ -92,17 +93,21 @@ typesOf moduleName vals = do return (ident, (val', varIfUnknown ty)) where -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values - tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts + tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (substituteType sub) val, substituteType sub ty))) ts -- Replace all the wildcards types with their inferred types - replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints $ WildcardInferredType (sub $? ty) - replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (sub $? ty)) + replace sub (ErrorMessage hints (WildcardInferredType ty)) = ErrorMessage hints . WildcardInferredType $ substituteType sub ty + replace sub (ErrorMessage hints (MissingTypeDeclaration name ty)) = ErrorMessage hints $ MissingTypeDeclaration name (varIfUnknown (substituteType sub ty)) replace _ em = em type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) type UntypedData = [(Ident, Type)] -typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) +typeDictionaryForBindingGroup :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + [(Ident, Expr)] -> + m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData) typeDictionaryForBindingGroup moduleName vals = do let -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed @@ -114,7 +119,7 @@ typeDictionaryForBindingGroup moduleName vals = do typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed -- Create fresh unification variables for the types of untyped declarations - untypedNames <- replicateM (length untyped) fresh + untypedNames <- replicateM (length untyped) freshType let -- Make a map of names to the unification variables of untyped declarations @@ -123,12 +128,17 @@ typeDictionaryForBindingGroup moduleName vals = do dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict) return (untyped, typed, dict, untypedDict) -checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type)) +checkTypedBindingGroupElement :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + (Ident, (Expr, Type, Bool)) -> + TypeData -> + m (Ident, (Expr, Type)) checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do -- Replace type wildcards ty' <- replaceTypeWildcards ty -- Kind check - (kind, args) <- liftCheck $ kindOfWithScopedVars ty + (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind -- Check the type with the new names in scope ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty' @@ -137,17 +147,21 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do else return (TypedValue False val' ty'') return (ident, (val'', ty'')) -typeForBindingGroupElement :: Bool -> (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type)) +typeForBindingGroupElement :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Bool -> + (Ident, Expr) -> + TypeData -> + UntypedData -> + m (Ident, (Expr, Type)) typeForBindingGroupElement warn (ident, val) dict untypedDict = do -- Infer the type with the new names in scope TypedValue _ val' ty <- bindNames dict $ infer val - ty =?= fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict) + unifyTypes ty $ fromMaybe (internalError "name not found in dictionary") (lookup ident untypedDict) when warn . tell . errorMessage $ MissingTypeDeclaration ident ty return (ident, (TypedValue True val' ty, ty)) --- | --- Check if a value contains a type annotation --- +-- | Check if a value contains a type annotation isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) isTyped (name, value) = Left (name, value) @@ -163,10 +177,12 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco g other = other --- | --- Replace type class dictionary placeholders with inferred type class dictionaries --- -replaceTypeClassDictionaries :: ModuleName -> Expr -> Check Expr +-- | Replace type class dictionary placeholders with inferred type class dictionaries +replaceTypeClassDictionaries :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + ModuleName -> + Expr -> + m Expr replaceTypeClassDictionaries mn = let (_, f, _) = everywhereOnValuesTopDownM return go return in f @@ -174,20 +190,24 @@ replaceTypeClassDictionaries mn = go (TypeClassDictionary constraint dicts) = entails mn dicts constraint go other = return other --- | --- Check the kind of a type, failing if it is not of kind *. --- -checkTypeKind :: Type -> Kind -> UnifyT t Check () +-- | Check the kind of a type, failing if it is not of kind *. +checkTypeKind :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + Type -> + Kind -> + m () checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star --- | --- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns +-- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns -- or TypeClassDictionary values. -- -- This is necessary during type checking to avoid unifying a polymorphic type with a -- unification variable. --- -instantiatePolyTypeWithUnknowns :: Expr -> Type -> UnifyT Type Check (Expr, Type) +instantiatePolyTypeWithUnknowns :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + Expr -> + Type -> + m (Expr, Type) instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do ty' <- replaceVarWithUnknown ident ty instantiatePolyTypeWithUnknowns val ty' @@ -197,48 +217,50 @@ instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do return (foldl App val (map (flip TypeClassDictionary dicts) constraints), ty') instantiatePolyTypeWithUnknowns val ty = return (val, ty) --- | --- Infer a type for a value, rethrowing any error to provide a more useful error message --- -infer :: Expr -> UnifyT Type Check Expr +-- | Infer a type for a value, rethrowing any error to provide a more useful error message +infer :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + m Expr infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val --- | --- Infer a type for a value --- -infer' :: Expr -> UnifyT Type Check Expr +-- | Infer a type for a value +infer' :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + m Expr infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber infer' v@(StringLiteral _) = return $ TypedValue True v tyString infer' v@(CharLiteral _) = return $ TypedValue True v tyChar infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean infer' (ArrayLiteral vals) = do - ts <- mapM infer vals - els <- fresh - forM_ ts $ \(TypedValue _ _ t) -> els =?= t + ts <- traverse infer vals + els <- freshType + forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els) infer' (ObjectLiteral ps) = do ensureNoDuplicateProperties ps - ts <- mapM (infer . snd) ps + ts <- traverse (infer . snd) ps let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts ty = TypeApp tyObject $ rowFromList (fields, REmpty) return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty infer' (ObjectUpdate o ps) = do ensureNoDuplicateProperties ps - row <- fresh - newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps + row <- freshType + newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals - oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh + oldTys <- zip (map fst ps) <$> replicateM (length ps) freshType let oldTy = TypeApp tyObject $ rowFromList (oldTys, row) o' <- TypedValue True <$> check o oldTy <*> pure oldTy return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row) infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do - field <- fresh - rest <- fresh + field <- freshType + rest <- freshType typed <- check val (TypeApp tyObject (RCons prop field rest)) return $ TypedValue True (Accessor prop typed) field infer' (Abs (Left arg) ret) = do - ty <- fresh + ty <- freshType Just moduleName <- checkCurrentModule <$> get withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do body@(TypedValue _ _ bodyTy) <- infer' ret @@ -265,7 +287,7 @@ infer' v@(Constructor c) = do return $ TypedValue True v' ty' infer' (Case vals binders) = do (vals', ts) <- instantiateForBinders vals binders - ret <- fresh + ret <- freshType binders' <- checkBinders ts ret binders return $ TypedValue True (Case vals' binders') ret infer' (IfThenElse cond th el) = do @@ -282,7 +304,7 @@ infer' (SuperClassDictionary className tys) = do return $ TypeClassDictionary (className, tys) dicts infer' (TypedValue checkType val ty) = do Just moduleName <- checkCurrentModule <$> get - (kind, args) <- liftCheck $ kindOfWithScopedVars ty + (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val @@ -290,22 +312,28 @@ infer' (TypedValue checkType val ty) = do infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val infer' _ = internalError "Invalid argument to infer" -inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr) +inferLetBinding :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + [Declaration] -> + [Declaration] -> + Expr -> + (Expr -> m Expr) -> + m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do Just moduleName <- checkCurrentModule <$> get - (kind, args) <- liftCheck $ kindOfWithScopedVars ty + (kind, args) <- kindOfWithScopedVars ty checkTypeKind ty kind let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do - valTy <- fresh + valTy <- freshType Just moduleName <- checkCurrentModule <$> get let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined) TypedValue _ val' valTy' <- bindNames dict $ infer val - valTy =?= valTy' + unifyTypes valTy valTy' bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get @@ -321,16 +349,18 @@ inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethr return (PositionedDeclaration pos com d' : ds', val') inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" --- | --- Infer the types of variables brought into scope by a binder --- -inferBinder :: Type -> Binder -> UnifyT Type Check (M.Map Ident Type) +-- | Infer the types of variables brought into scope by a binder +inferBinder :: forall m. + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Type -> + Binder -> + m (M.Map Ident Type) inferBinder _ NullBinder = return M.empty -inferBinder val (StringBinder _) = val =?= tyString >> return M.empty -inferBinder val (CharBinder _) = val =?= tyChar >> return M.empty -inferBinder val (NumberBinder (Left _)) = val =?= tyInt >> return M.empty -inferBinder val (NumberBinder (Right _)) = val =?= tyNumber >> return M.empty -inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty +inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty +inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty +inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty +inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty +inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty inferBinder val (VarBinder name) = return $ M.singleton name val inferBinder val (ConstructorBinder ctor binders) = do env <- getEnv @@ -340,7 +370,7 @@ inferBinder val (ConstructorBinder ctor binders) = do fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn let (args, ret) = peelArgs fn' unless (length args == length binders) . throwError . errorMessage $ IncorrectConstructorArity ctor - ret =?= val + unifyTypes ret val M.unions <$> zipWithM inferBinder (reverse args) binders _ -> throwError . errorMessage $ UnknownDataConstructor ctor Nothing where @@ -350,23 +380,23 @@ inferBinder val (ConstructorBinder ctor binders) = do go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret go args ret = (args, ret) inferBinder val (ObjectBinder props) = do - row <- fresh - rest <- fresh + row <- freshType + rest <- freshType m1 <- inferRowProperties row rest props - val =?= TypeApp tyObject row + unifyTypes val (TypeApp tyObject row) return m1 where - inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type) - inferRowProperties nrow row [] = nrow =?= row >> return M.empty + inferRowProperties :: Type -> Type -> [(String, Binder)] -> m (M.Map Ident Type) + inferRowProperties nrow row [] = unifyTypes nrow row >> return M.empty inferRowProperties nrow row ((name, binder):binders) = do - propTy <- fresh + propTy <- freshType m1 <- inferBinder propTy binder m2 <- inferRowProperties nrow (RCons name propTy row) binders return $ m1 `M.union` m2 inferBinder val (ArrayBinder binders) = do - el <- fresh - m1 <- M.unions <$> mapM (inferBinder el) binders - val =?= TypeApp tyArray el + el <- freshType + m1 <- M.unions <$> traverse (inferBinder el) binders + unifyTypes val (TypeApp tyArray el) return m1 inferBinder val (NamedBinder name binder) = do m <- inferBinder val binder @@ -378,9 +408,9 @@ inferBinder val (PositionedBinder pos _ binder) = -- and use `kindOfWithScopedVars`. inferBinder val (TypedBinder ty binder) = do ty1 <- replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - kind <- liftCheck $ kindOf ty1 + kind <- kindOf ty1 checkTypeKind ty1 kind - val =?= ty1 + unifyTypes val ty1 inferBinder val binder -- | Returns true if a binder requires its argument type to be a monotype. @@ -393,7 +423,11 @@ binderRequiresMonotype (PositionedBinder _ _ b) = binderRequiresMonotype b binderRequiresMonotype _ = True -- | Instantiate polytypes only when necessitated by a binder. -instantiateForBinders :: [Expr] -> [CaseAlternative] -> UnifyT Type Check ([Expr], [Type]) +instantiateForBinders :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + [Expr] -> + [CaseAlternative] -> + m ([Expr], [Type]) instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do TypedValue _ val' ty <- infer val if inst @@ -406,7 +440,12 @@ instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do -- | -- Check the types of the return values in a set of binders in a case statement -- -checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative] +checkBinders :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + [Type] -> + Type -> + [CaseAlternative] -> + m [CaseAlternative] checkBinders _ _ [] = return [] checkBinders nvals ret (CaseAlternative binders result : bs) = do guardWith (errorMessage $ OverlappingArgNames Nothing) $ @@ -431,13 +470,21 @@ checkBinders nvals ret (CaseAlternative binders result : bs) = do -- | -- Check the type of a value, rethrowing errors to provide a better error message -- -check :: Expr -> Type -> UnifyT Type Check Expr +check :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + Type -> + m Expr check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty -- | -- Check the type of a value -- -check' :: Expr -> Type -> UnifyT Type Check Expr +check' :: forall m. + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + Type -> + m Expr check' val (ForAll ident ty _) = do scope <- newSkolemScope sko <- newSkolemConstant @@ -447,15 +494,15 @@ check' val (ForAll ident ty _) = do return $ TypedValue True val' (ForAll ident ty (Just scope)) check' val t@(ConstrainedType constraints ty) = do dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do - n <- liftCheck freshDictionaryName + n <- freshDictionaryName return $ Ident $ "__dict_" ++ className ++ "_" ++ show n - dicts <- join <$> liftCheck (zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints) + dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue True (foldr (Abs . Left) val' dictNames) t where -- | Add a dictionary for the constraint to the scope, and dictionaries - -- for all implies superclass instances. - newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> Check [TypeClassDictionaryInScope] + -- for all implied superclass instances. + newDictionaries :: [(Qualified ProperName, Integer)] -> Qualified Ident -> (Qualified ProperName, [Type]) -> m [TypeClassDictionaryInScope] newDictionaries path name (className, instanceTy) = do tcs <- gets (typeClasses . checkEnv) let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs @@ -472,7 +519,7 @@ check' val u@(TUnknown _) = do val'@(TypedValue _ _ ty) <- infer val -- Don't unify an unknown with an inferred polytype (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty - ty' =?= u + unifyTypes ty' u return $ TypedValue True val'' ty' check' v@(NumericLiteral (Left _)) t | t == tyInt = return $ TypedValue True v t @@ -485,11 +532,11 @@ check' v@(CharLiteral _) t | t == tyChar = check' v@(BooleanLiteral _) t | t == tyBoolean = return $ TypedValue True v t check' (ArrayLiteral vals) t@(TypeApp a ty) = do - a =?= tyArray + unifyTypes a tyArray array <- ArrayLiteral <$> forM vals (`check` ty) return $ TypedValue True array t check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do - t =?= tyFunction + unifyTypes t tyFunction Just moduleName <- checkCurrentModule <$> get ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy return $ TypedValue True (Abs (Left arg) ret') ty @@ -518,7 +565,7 @@ check' (SuperClassDictionary className tys) _ = do return $ TypeClassDictionary (className, tys) dicts check' (TypedValue checkType val ty1) ty2 = do Just moduleName <- checkCurrentModule <$> get - (kind, args) <- liftCheck $ kindOfWithScopedVars ty1 + (kind, args) <- kindOfWithScopedVars ty1 checkTypeKind ty1 kind ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2 @@ -550,12 +597,12 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do -- We check _obj_ against the type _t_ with the types in _ps_ replaced with unknowns. let (propsToCheck, rest) = rowToList row (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck - us <- zip (map fst removedProps) <$> replicateM (length ps) fresh + us <- zip (map fst removedProps) <$> replicateM (length ps) freshType obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest))) ps' <- checkProperties e ps row True return $ TypedValue True (ObjectUpdate obj' ps') t check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do - rest <- fresh + rest <- freshType val' <- check val (TypeApp tyObject (RCons prop ty rest)) return $ TypedValue True (Accessor prop val') ty check' v@(Constructor c) ty = do @@ -589,12 +636,18 @@ check' val ty = do -- -- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case. -- -checkProperties :: Expr -> [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)] +checkProperties :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + [(String, Expr)] -> + Type -> + Bool -> + m [(String, Expr)] checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' where go [] [] REmpty = return [] go [] [] u@(TUnknown _) | lax = return [] - | otherwise = do u =?= REmpty + | otherwise = do unifyTypes u REmpty return [] go [] [] Skolem{} | lax = return [] go [] ((p, _): _) _ | lax = return [] @@ -604,8 +657,8 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh case lookup p ts of Nothing -> do v'@(TypedValue _ _ ty) <- infer v - rest <- fresh - r =?= RCons p ty rest + rest <- freshType + unifyTypes r (RCons p ty rest) ps'' <- go ps' ts rest return $ (p, v') : ps'' Just ty -> do @@ -614,20 +667,28 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps ts r' wh return $ (p, v') : ps'' go _ _ _ = throwError . errorMessage $ ExprDoesNotHaveType expr (TypeApp tyObject row) --- | --- Check the type of a function application, rethrowing errors to provide a better error message --- -checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr) +-- | Check the type of a function application, rethrowing errors to provide a better error message +checkFunctionApplication :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + Type -> + Expr -> + Maybe Type -> + m (Type, Expr) checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do - subst <- unifyCurrentSubstitution <$> UnifyT get - checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret) - --- | --- Check the type of a function application --- -checkFunctionApplication' :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr) + subst <- gets checkSubstitution + checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret) + +-- | Check the type of a function application +checkFunctionApplication' :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => + Expr -> + Type -> + Expr -> + Maybe Type -> + m (Type, Expr) checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do - tyFunction' =?= tyFunction + unifyTypes tyFunction' tyFunction arg' <- check arg argTy case ret of Nothing -> return (retTy, App fn arg') @@ -643,8 +704,8 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t return $ TypedValue True arg'' t' let ty = (\(TypedValue _ _ t) -> t) arg' - ret' <- maybe fresh return ret - u =?= function ty ret' + ret' <- maybe freshType return ret + unifyTypes u (function ty ret') return (ret', App fn arg') checkFunctionApplication' fn (KindedType ty _) arg ret = checkFunctionApplication fn ty arg ret @@ -655,11 +716,15 @@ checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ = return (fnTy, App fn dict) checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg --- | --- Compute the meet of two types, i.e. the most general type which both types subsume. --- TODO: handle constrained types --- -meet :: Expr -> Expr -> Type -> Type -> UnifyT Type Check (Expr, Expr, Type) +-- | Compute the meet of two types, i.e. the most general type which both types subsume. +-- TODO: is this really needed? +meet :: + (Functor m, Applicative m, MonadState CheckState m, MonadError MultipleErrors m) => + Expr -> + Expr -> + Type -> + Type -> + m (Expr, Expr, Type) meet e1 e2 (ForAll ident t1 _) t2 = do t1' <- replaceVarWithUnknown ident t1 meet e1 e2 t1' t2 @@ -667,7 +732,7 @@ meet e1 e2 t1 (ForAll ident t2 _) = do t2' <- replaceVarWithUnknown ident t2 meet e1 e2 t1 t2' meet e1 e2 t1 t2 = do - t1 =?= t2 + unifyTypes t1 t2 return (e1, e2, t1) -- | diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 4ffe2b6..241c52e 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -13,12 +13,16 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module Language.PureScript.TypeChecker.Unify ( + freshType, + solveType, + substituteType, unifyTypes, unifyRows, unifiesWith, @@ -28,13 +32,15 @@ module Language.PureScript.TypeChecker.Unify ( ) where import Data.List (nub, sort) -import Data.Maybe (fromMaybe) -import qualified Data.HashMap.Strict as H +import qualified Data.Map as M +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif import Control.Monad -import Control.Monad.Unify -import Control.Monad.Writer import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.State.Class (MonadState(..), gets, modify) import Language.PureScript.Crash import Language.PureScript.Errors @@ -42,32 +48,59 @@ import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Skolems import Language.PureScript.Types -instance Partial Type where - unknown = TUnknown - isUnknown (TUnknown u) = Just u - isUnknown _ = Nothing - unknowns = everythingOnTypes (++) go - where - go (TUnknown u) = [u] - go _ = [] - ($?) sub = everywhereOnTypes go - where - go t@(TUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub) - go other = other - -instance Unifiable Check Type where - (=?=) = unifyTypes +-- | Generate a fresh type variable +freshType :: (MonadState CheckState m) => m Type +freshType = do + t <- gets checkNextType + modify $ \st -> st { checkNextType = t + 1 } + return $ TUnknown t --- | --- Unify two types, updating the current substitution --- -unifyTypes :: Type -> Type -> UnifyT Type Check () -unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ - unifyTypes' t1 t2 +-- | Update the substitution to solve a type constraint +solveType :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Int -> Type -> m () +solveType u t = do + occursCheck u t + modify $ \cs -> cs { checkSubstitution = + (checkSubstitution cs) { substType = + M.insert u t $ substType $ checkSubstitution cs + } + } + +-- | Apply a substitution to a type +substituteType :: Substitution -> Type -> Type +substituteType sub = everywhereOnTypes go + where + go (TUnknown u) = + case M.lookup u (substType sub) of + Nothing -> TUnknown u + Just (TUnknown u1) | u1 == u -> TUnknown u1 + Just t -> substituteType sub t + go other = other + +-- | Make sure that an unknown does not occur in a type +occursCheck :: (Functor m, Applicative m, MonadError MultipleErrors m) => Int -> Type -> m () +occursCheck _ TUnknown{} = return () +occursCheck u t = void $ everywhereOnTypesM go t + where + go (TUnknown u') | u == u' = throwError . errorMessage . InfiniteType $ t + go other = return other + +-- | Compute a list of all unknowns appearing in a type +unknownsInType :: Type -> [Int] +unknownsInType t = everythingOnTypes (.) go t [] + where + go :: Type -> [Int] -> [Int] + go (TUnknown u) = (u :) + go _ = id + +-- | Unify two types, updating the current substitution +unifyTypes :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () +unifyTypes t1 t2 = do + sub <- gets checkSubstitution + rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) where unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return () - unifyTypes' (TUnknown u) t = u =:= t - unifyTypes' t (TUnknown u) = u =:= t + unifyTypes' (TUnknown u) t = solveType u t + unifyTypes' t (TUnknown u) = solveType u t unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) = case (sc1, sc2) of (Just sc1', Just sc2') -> do @@ -106,7 +139,7 @@ unifyTypes t1 t2 = rethrow (addHint (ErrorUnifyingTypes t1 t2)) $ -- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification -- error. -- -unifyRows :: Type -> Type -> UnifyT Type Check () +unifyRows :: forall m. (Functor m, Applicative m, MonadError MultipleErrors m, MonadState CheckState m) => Type -> Type -> m () unifyRows r1 r2 = let (s1, r1') = rowToList r1 @@ -115,18 +148,18 @@ unifyRows r1 r2 = sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ] sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] in do - forM_ int (uncurry (=?=)) + forM_ int (uncurry unifyTypes) unifyRows' sd1 r1' sd2 r2' where - unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check () - unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r) - unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r) + unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> m () + unifyRows' [] (TUnknown u) sd r = solveType u (rowFromList (sd, r)) + unifyRows' sd r [] (TUnknown u) = solveType u (rowFromList (sd, r)) unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do forM_ sd1 $ \(_, t) -> occursCheck u2 t forM_ sd2 $ \(_, t) -> occursCheck u1 t - rest <- fresh - u1 =:= rowFromList (sd2, rest) - u2 =:= rowFromList (sd1, rest) + rest <- freshType + solveType u1 (rowFromList (sd2, rest)) + solveType u2 (rowFromList (sd1, rest)) unifyRows' [] REmpty [] REmpty = return () unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return () unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return () @@ -164,21 +197,21 @@ unifiesWith _ _ = False -- | -- Replace a single type variable with a new unification variable -- -replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type +replaceVarWithUnknown :: (MonadState CheckState m) => String -> Type -> m Type replaceVarWithUnknown ident ty = do - tu <- fresh + tu <- freshType return $ replaceTypeVars ident tu ty -- | -- Replace type wildcards with unknowns -- -replaceTypeWildcards :: Type -> UnifyT t Check Type +replaceTypeWildcards :: (Functor m, Applicative m, MonadWriter MultipleErrors m, MonadState CheckState m) => Type -> m Type replaceTypeWildcards = everywhereOnTypesM replace where replace TypeWildcard = do - u <- fresh' - liftCheck . tell $ errorMessage . WildcardInferredType $ TUnknown u - return $ TUnknown u + t <- freshType + tell . errorMessage $ WildcardInferredType t + return t replace other = return other -- | @@ -186,7 +219,7 @@ replaceTypeWildcards = everywhereOnTypesM replace -- varIfUnknown :: Type -> Type varIfUnknown ty = - let unks = nub $ unknowns ty + let unks = nub $ unknownsInType ty toName = (:) 't' . show ty' = everywhereOnTypes typeToVar ty typeToVar :: Type -> Type diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index dec6641..940a5c3 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -16,21 +16,19 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} module Language.PureScript.Types where +import Prelude () +import Prelude.Compat + import Data.Data import Data.List (nub) import Data.Maybe (fromMaybe) import qualified Data.Aeson as A import qualified Data.Aeson.TH as A -import Control.Monad.Unify import Control.Arrow (second) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Monad ((<=<)) import Language.PureScript.Names @@ -49,7 +47,7 @@ data Type -- | -- A unification variable of type Type -- - = TUnknown Unknown + = TUnknown Int -- | -- A named type variable -- diff --git a/tests/Main.hs b/tests/Main.hs index eca7129..1b5c834 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -14,9 +14,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} -- Failing tests can specify the kind of error that should be thrown with a -- @shouldFailWith declaration. For example: @@ -35,6 +33,9 @@ module Main (main) where +import Prelude () +import Prelude.Compat + import qualified Language.PureScript as P import qualified Language.PureScript.CodeGen.JS as J import qualified Language.PureScript.CoreFn as CF @@ -42,18 +43,12 @@ import qualified Language.PureScript.CoreFn as CF import Data.Char (isSpace) import Data.Maybe (mapMaybe, fromMaybe) import Data.List (isSuffixOf, sort, stripPrefix) -#if __GLASGOW_HASKELL__ < 710 -import Data.Traversable (traverse) -#endif import Data.Time.Clock (UTCTime()) import qualified Data.Map as M import Control.Monad import Control.Monad.IO.Class (liftIO) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif import Control.Arrow ((>>>)) import Control.Monad.Reader diff --git a/tests/common/TestsSetup.hs b/tests/common/TestsSetup.hs index 2dc1458..1ec2cd1 100644 --- a/tests/common/TestsSetup.hs +++ b/tests/common/TestsSetup.hs @@ -10,18 +10,13 @@ -- | -- ----------------------------------------------------------------------------- - -{-# LANGUAGE CPP #-} - module TestsSetup where -import Data.Maybe (fromMaybe) +import Prelude () +import Prelude.Compat -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif +import Data.Maybe (fromMaybe) import Control.Monad - import Control.Monad.Trans.Maybe import System.Process |