summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--CONTRIBUTING.md2
-rw-r--r--CONTRIBUTORS.md3
-rw-r--r--LICENSE1037
-rw-r--r--README.md1
-rw-r--r--examples/failing/1175.purs11
-rw-r--r--examples/passing/1335.purs12
-rw-r--r--examples/passing/FieldConsPuns.purs10
-rw-r--r--examples/passing/FieldPuns.purs8
-rw-r--r--examples/passing/OperatorSections.purs6
-rw-r--r--examples/passing/StringEscapes.purs15
-rw-r--r--psc-bundle/Main.hs38
-rw-r--r--psc-docs/Ctags.hs2
-rw-r--r--psc-docs/Etags.hs4
-rw-r--r--psc-publish/Main.hs11
-rw-r--r--psci/Completion.hs19
-rw-r--r--psci/PSCi.hs150
-rw-r--r--psci/Parser.hs9
-rw-r--r--psci/tests/Main.hs7
-rw-r--r--purescript.cabal15
-rw-r--r--src/Control/Monad/Logger.hs8
-rw-r--r--src/Control/Monad/Supply.hs7
-rw-r--r--src/Control/Monad/Unify.hs160
-rw-r--r--src/Language/PureScript.hs1
-rw-r--r--src/Language/PureScript/AST/Declarations.hs8
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs8
-rw-r--r--src/Language/PureScript/AST/Traversals.hs125
-rw-r--r--src/Language/PureScript/Bundle.hs40
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs7
-rw-r--r--src/Language/PureScript/CodeGen/JS/AST.hs10
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer.hs7
-rw-r--r--src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs8
-rw-r--r--src/Language/PureScript/Docs/ParseAndDesugar.hs13
-rw-r--r--src/Language/PureScript/Docs/Render.hs10
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Render.hs9
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/Types.hs9
-rw-r--r--src/Language/PureScript/Docs/Types.hs7
-rw-r--r--src/Language/PureScript/Errors.hs95
-rw-r--r--src/Language/PureScript/Externs.hs7
-rw-r--r--src/Language/PureScript/Kinds.hs11
-rw-r--r--src/Language/PureScript/Linter.hs9
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs7
-rw-r--r--src/Language/PureScript/Linter/Imports.hs128
-rw-r--r--src/Language/PureScript/Make.hs21
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs63
-rw-r--r--src/Language/PureScript/Parser/JS.hs8
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs8
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs2
-rw-r--r--src/Language/PureScript/Pretty/JS.hs20
-rw-r--r--src/Language/PureScript/Pretty/Types.hs2
-rw-r--r--src/Language/PureScript/Pretty/Values.hs144
-rw-r--r--src/Language/PureScript/Publish.hs33
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs66
-rw-r--r--src/Language/PureScript/Renamer.hs27
-rw-r--r--src/Language/PureScript/Sugar.hs15
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs8
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs7
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs7
-rw-r--r--src/Language/PureScript/Sugar/Names.hs53
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs10
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs21
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs7
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs13
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs11
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses/Deriving.hs473
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs13
-rw-r--r--src/Language/PureScript/Traversals.hs7
-rw-r--r--src/Language/PureScript/TypeChecker.hs141
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs34
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs222
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs228
-rw-r--r--src/Language/PureScript/TypeChecker/Rows.hs20
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs56
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs40
-rw-r--r--src/Language/PureScript/TypeChecker/Synonyms.hs7
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs303
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs119
-rw-r--r--src/Language/PureScript/Types.hs10
-rw-r--r--tests/Main.hs11
-rw-r--r--tests/common/TestsSetup.hs11
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
diff --git a/LICENSE b/LICENSE
index 6f84bf8..00e252b 100644
--- a/LICENSE
+++ b/LICENSE
@@ -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
diff --git a/README.md b/README.md
index aa4a4ff..cc391f7 100644
--- a/README.md
+++ b/README.md
@@ -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