diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -160,6 +160,8 @@ | [@sd-yip](https://github.com/sd-yip) | Nicholas Yip | [MIT license](http://opensource.org/licenses/MIT) | | [@j-nava](https://github.com/j-nava) | Jesse Nava | [MIT license](http://opensource.org/licenses/MIT) | | [@imcotton](https://github.com/imcotton) | Cotton Hou | [MIT license](http://opensource.org/licenses/MIT) | +| [@wclr](https://github.com/wclr) | Alex Osh | [MIT license](http://opensource.org/licenses/MIT) | +| [@Deltaspace0](https://github.com/Deltaspace0) | Ruslan Gadeev | [MIT license](http://opensource.org/licenses/MIT) | ### Contributors using Modified Terms diff --git a/INSTALL.md b/INSTALL.md --- a/INSTALL.md +++ b/INSTALL.md @@ -4,12 +4,12 @@ ## Requirements -The PureScript compiler is built using GHC 9.2.3, and should be able to run on any operating system supported by GHC 9.2.3. In particular: +The PureScript compiler is built using GHC 9.2.4, and should be able to run on any operating system supported by GHC 9.2.4. In particular: * for Windows users, versions predating Vista are not officially supported, * for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported. -See also for more details about the operating systems which GHC 9.2.3 supports. +See also for more details about the operating systems which GHC 9.2.4 supports. ## Official prebuilt binaries diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -22,7 +22,6 @@ adjunctions aeson aeson-better-errors - aeson-pretty alex ansi-terminal ansi-wl-pprint @@ -45,9 +44,7 @@ boxes bytestring call-stack - case-insensitive cborg - cereal cheapskate clock colour @@ -77,15 +74,12 @@ file-embed filepath free - fsnotify ghc-bignum ghc-prim half happy hashable haskeline - hfsevents - http-types indexed-traversable indexed-traversable-instances integer-gmp @@ -422,39 +416,6 @@ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -aeson-pretty LICENSE file: - - Copyright (c)2011, Falko Peters - - 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 Falko Peters 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. - alex LICENSE file: Copyright (c) 1995-2011, Chris Dornan and Simon Marlow @@ -1204,40 +1165,6 @@ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -case-insensitive LICENSE file: - - Copyright (c) 2011-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. - - * The name of Bas van Dijk and the names of contributors 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 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. - cborg LICENSE file: Copyright (c) 2015-2017 Duncan Coutts, @@ -1274,39 +1201,6 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -cereal LICENSE file: - - Copyright (c) Lennart Kolmodin, Galois, 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 - DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR - ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, - STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN - ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - POSSIBILITY OF SUCH DAMAGE. - cheapskate LICENSE file: Copyright (c) 2013, John MacFarlane @@ -2200,39 +2094,6 @@ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -fsnotify LICENSE file: - - Copyright (c) 2012, Mark Dittmer - - 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 Mark Dittmer 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. - ghc-bignum LICENSE file: The Glasgow Haskell Compiler License @@ -2454,73 +2315,6 @@ 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. - -hfsevents LICENSE file: - - Copyright (c) 2012, Luite Stegeman - - 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 Luite Stegeman nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - 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. - -http-types LICENSE file: - - Copyright (c) 2011, Aristid Breitkreuz - Copyright (c) 2011, Michael Snoyman - - 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 Aristid Breitkreuz 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. indexed-traversable LICENSE file: diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: purescript -version: 0.15.6 +version: 0.15.7 license: BSD-3-Clause license-file: LICENSE copyright: @@ -76,11 +76,7 @@ Language.PureScript.CodeGen.JS Language.PureScript.CodeGen.JS.Common Language.PureScript.CodeGen.JS.Printer - Language.PureScript.Constants.Prelude - Language.PureScript.Constants.Data.Foldable - Language.PureScript.Constants.Data.Generic.Rep - Language.PureScript.Constants.Data.Newtype - Language.PureScript.Constants.Data.Traversable + Language.PureScript.Constants.Libs Language.PureScript.CoreFn Language.PureScript.CoreFn.Ann Language.PureScript.CoreFn.Binders @@ -151,7 +147,9 @@ Language.PureScript.Ide.Externs Language.PureScript.Ide.Filter Language.PureScript.Ide.Filter.Declaration + Language.PureScript.Ide.Filter.Imports Language.PureScript.Ide.Imports + Language.PureScript.Ide.Imports.Actions Language.PureScript.Ide.Logging Language.PureScript.Ide.Matcher Language.PureScript.Ide.Prim @@ -239,6 +237,7 @@ hs-source-dirs: src other-modules: Data.Text.PureScript + Language.PureScript.Constants.TH Paths_purescript autogen-modules: Paths_purescript @@ -254,12 +253,18 @@ TupleSections TypeFamilies ViewPatterns ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missed-specialisations + -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe + -Wno-trustworthy-safe -Wno-inferred-safe-imports + -Wno-missing-safe-haskell-mode -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-missing-deriving-strategies + -Wno-missing-export-lists -Wno-missing-kind-signatures + -Wno-partial-fields -Wno-prepositive-qualified-module build-depends: aeson >=2.0.3.0 && <2.1, aeson-better-errors >=0.9.1.1 && <0.10, - aeson-pretty >=0.8.9 && <0.9, ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.17, @@ -273,15 +278,14 @@ cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, - cryptonite ==0.30.*, + cryptonite >=0.30 && <0.31, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, directory >=1.3.6.2 && <1.4, - dlist ==1.0.*, + dlist >=1.0 && <1.1, edit-distance >=0.2.2.1 && <0.3, file-embed >=0.0.15.0 && <0.1, filepath >=1.4.2.2 && <1.5, - fsnotify >=0.3.0.1 && <0.4, Glob >=0.10.2 && <0.11, haskeline >=0.8.2 && <0.9, language-javascript ==0.7.0.0, @@ -301,21 +305,17 @@ regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, - semigroups ==0.20.*, + semigroups >=0.20 && <0.21, semialign >=1.2.0.1 && <1.3, sourcemap >=0.1.7 && <0.2, - split >=0.2.3.4 && <0.3, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, - syb >=0.7.2.1 && <0.8, + template-haskell >=2.18.0.0 && <2.19, text >=1.2.5.0 && <1.3, these >=1.1.1.1 && <1.2, time >=1.11.1.1 && <1.12, transformers >=0.5.6.2 && <0.6, transformers-base >=0.4.6 && <0.5, - transformers-compat >=0.7.1 && <0.8, - typed-process >=0.2.10.1 && <0.3, - unordered-containers >=0.2.19.1 && <0.3, utf8-string >=1.0.2 && <1.1, vector >=0.12.3.1 && <0.13, witherable >=0.4.2 && <0.5 @@ -351,13 +351,20 @@ TupleSections TypeFamilies ViewPatterns ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missed-specialisations + -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe + -Wno-trustworthy-safe -Wno-inferred-safe-imports + -Wno-missing-safe-haskell-mode -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-missing-deriving-strategies + -Wno-missing-export-lists -Wno-missing-kind-signatures + -Wno-partial-fields -Wno-prepositive-qualified-module -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + -Wno-unused-packages build-depends: aeson >=2.0.3.0 && <2.1, aeson-better-errors >=0.9.1.1 && <0.10, - aeson-pretty >=0.8.9 && <0.9, ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.17, @@ -371,15 +378,14 @@ cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, - cryptonite ==0.30.*, + cryptonite >=0.30 && <0.31, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, directory >=1.3.6.2 && <1.4, - dlist ==1.0.*, + dlist >=1.0 && <1.1, edit-distance >=0.2.2.1 && <0.3, file-embed >=0.0.15.0 && <0.1, filepath >=1.4.2.2 && <1.5, - fsnotify >=0.3.0.1 && <0.4, Glob >=0.10.2 && <0.11, haskeline >=0.8.2 && <0.9, language-javascript ==0.7.0.0, @@ -399,31 +405,25 @@ regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, - semigroups ==0.20.*, + semigroups >=0.20 && <0.21, semialign >=1.2.0.1 && <1.3, sourcemap >=0.1.7 && <0.2, - split >=0.2.3.4 && <0.3, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, - syb >=0.7.2.1 && <0.8, + template-haskell >=2.18.0.0 && <2.19, text >=1.2.5.0 && <1.3, these >=1.1.1.1 && <1.2, time >=1.11.1.1 && <1.12, transformers >=0.5.6.2 && <0.6, transformers-base >=0.4.6 && <0.5, - transformers-compat >=0.7.1 && <0.8, - typed-process >=0.2.10.1 && <0.3, - unordered-containers >=0.2.19.1 && <0.3, utf8-string >=1.0.2 && <1.1, vector >=0.12.3.1 && <0.13, witherable >=0.4.2 && <0.5, ansi-wl-pprint >=0.6.9 && <0.7, exceptions >=0.10.4 && <0.11, - file-embed >=0.0.13.0 && <0.1, - http-types >=0.12.3 && <0.13, network >=3.1.2.7 && <3.2, optparse-applicative >=0.17.0.0 && <0.18, - purescript -any + purescript if flag(release) cpp-options: -DRELEASE @@ -435,8 +435,8 @@ type: exitcode-stdio-1.0 main-is: Main.hs build-tool-depends: - happy:happy ==1.20.0, hspec-discover:hspec-discover -any, - purescript:purs -any + happy:happy ==1.20.0, hspec-discover:hspec-discover, + purescript:purs hs-source-dirs: tests other-modules: @@ -483,13 +483,19 @@ TupleSections TypeFamilies ViewPatterns ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wno-incomplete-uni-patterns + -Weverything -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missed-specialisations + -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe + -Wno-trustworthy-safe -Wno-inferred-safe-imports + -Wno-missing-safe-haskell-mode -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-missing-deriving-strategies + -Wno-missing-export-lists -Wno-missing-kind-signatures + -Wno-partial-fields -Wno-prepositive-qualified-module + -Wno-incomplete-uni-patterns -Wno-unused-packages build-depends: aeson >=2.0.3.0 && <2.1, aeson-better-errors >=0.9.1.1 && <0.10, - aeson-pretty >=0.8.9 && <0.9, ansi-terminal >=0.11.3 && <0.12, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.17, @@ -503,15 +509,14 @@ cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, - cryptonite ==0.30.*, + cryptonite >=0.30 && <0.31, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, directory >=1.3.6.2 && <1.4, - dlist ==1.0.*, + dlist >=1.0 && <1.1, edit-distance >=0.2.2.1 && <0.3, file-embed >=0.0.15.0 && <0.1, filepath >=1.4.2.2 && <1.5, - fsnotify >=0.3.0.1 && <0.4, Glob >=0.10.2 && <0.11, haskeline >=0.8.2 && <0.9, language-javascript ==0.7.0.0, @@ -531,28 +536,26 @@ regex-tdfa >=1.3.1.2 && <1.4, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, - semigroups ==0.20.*, + semigroups >=0.20 && <0.21, semialign >=1.2.0.1 && <1.3, sourcemap >=0.1.7 && <0.2, - split >=0.2.3.4 && <0.3, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, - syb >=0.7.2.1 && <0.8, + template-haskell >=2.18.0.0 && <2.19, text >=1.2.5.0 && <1.3, these >=1.1.1.1 && <1.2, time >=1.11.1.1 && <1.12, transformers >=0.5.6.2 && <0.6, transformers-base >=0.4.6 && <0.5, - transformers-compat >=0.7.1 && <0.8, - typed-process >=0.2.10.1 && <0.3, - unordered-containers >=0.2.19.1 && <0.3, utf8-string >=1.0.2 && <1.1, vector >=0.12.3.1 && <0.13, witherable >=0.4.2 && <0.5, - purescript -any, + purescript, generic-random >=1.5.0.1 && <1.6, hspec ==2.9.2, HUnit >=1.6.2.0 && <1.7, newtype >=0.2.2.0 && <0.3, QuickCheck >=2.14.2 && <2.15, - regex-base >=0.94.0.2 && <0.95 + regex-base >=0.94.0.2 && <0.95, + split >=0.2.3.4 && <0.3, + typed-process >=0.2.10.1 && <0.3 diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -147,7 +147,7 @@ importPrim :: Module -> Module importPrim = let - primModName = C.Prim + primModName = C.M_Prim in addDefaultImport (Qualified (ByModuleName primModName) primModName) . addDefaultImport (Qualified ByNullSourcePos primModName) diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs --- a/src/Language/PureScript/CST/Layout.hs +++ b/src/Language/PureScript/CST/Layout.hs @@ -82,7 +82,7 @@ -- ] of -- @ -- --- Which of the above 13 commas function as the separaters between the +-- Which of the above 13 commas function as the separators between the -- case binders (e.g. @one@) in the outermost @case ... of@ context? -- -- ### The Solution diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs --- a/src/Language/PureScript/CST/Lexer.hs +++ b/src/Language/PureScript/CST/Lexer.hs @@ -201,7 +201,7 @@ goWs a _ = a goSpace a !n (' ' : ls) = goSpace a (n + 1) ls - goSpace a !n ls = goWs (Space n : a) ls + goSpace a n ls = goWs (Space n : a) ls isBlockComment = Parser $ \inp _ ksucc -> case Text.uncons inp of @@ -725,7 +725,7 @@ digitsToScientific = go 0 . reverse where go !exp is [] = (digitsToInteger (reverse is), exp) - go !exp is (f : fs) = go (exp - 1) (f : is) fs + go exp is (f : fs) = go (exp - 1) (f : is) fs isSymbolChar :: Char -> Bool isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String)) || (not (Char.isAscii c) && Char.isSymbol c) diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -52,7 +52,7 @@ -- module. moduleToJs :: forall m - . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) + . (MonadReader Options m, MonadSupply m, MonadError MultipleErrors m) => Module Ann -> Maybe PSString -> m AST.Module @@ -232,7 +232,7 @@ moduleBindToJs :: forall m - . (Monad m, MonadReader Options m, MonadSupply m, MonadWriter Any m, MonadError MultipleErrors m) + . (MonadReader Options m, MonadSupply m, MonadWriter Any m, MonadError MultipleErrors m) => ModuleName -> Bind Ann -> m [AST] @@ -393,7 +393,7 @@ -- | Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST - qualifiedToJS f (Qualified (ByModuleName C.Prim) a) = AST.Var Nothing . runIdent $ f a + qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a) = AST.Var Nothing . runIdent $ f a qualifiedToJS f (Qualified (ByModuleName mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) diff --git a/src/Language/PureScript/Constants/Data/Foldable.hs b/src/Language/PureScript/Constants/Data/Foldable.hs deleted file mode 100644 --- a/src/Language/PureScript/Constants/Data/Foldable.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Language.PureScript.Constants.Data.Foldable where - -import Data.String (IsString) -import Language.PureScript.Names - -foldl :: forall a. (IsString a) => a -foldl = "foldl" - -foldr :: forall a. (IsString a) => a -foldr = "foldr" - -foldMap :: forall a. (IsString a) => a -foldMap = "foldMap" - -pattern DataFoldable :: ModuleName -pattern DataFoldable = ModuleName "Data.Foldable" - -pattern Foldable :: Qualified (ProperName 'ClassName) -pattern Foldable = Qualified (ByModuleName DataFoldable) (ProperName "Foldable") - -identFoldl :: Qualified Ident -identFoldl = Qualified (ByModuleName DataFoldable) (Ident foldl) - -identFoldr :: Qualified Ident -identFoldr = Qualified (ByModuleName DataFoldable) (Ident foldr) - -identFoldMap :: Qualified Ident -identFoldMap = Qualified (ByModuleName DataFoldable) (Ident foldMap) diff --git a/src/Language/PureScript/Constants/Data/Generic/Rep.hs b/src/Language/PureScript/Constants/Data/Generic/Rep.hs deleted file mode 100644 --- a/src/Language/PureScript/Constants/Data/Generic/Rep.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Language.PureScript.Constants.Data.Generic.Rep where - -import Language.PureScript.Names - -pattern DataGenericRep :: ModuleName -pattern DataGenericRep = ModuleName "Data.Generic.Rep" - -pattern Generic :: Qualified (ProperName 'ClassName) -pattern Generic = Qualified (ByModuleName DataGenericRep) (ProperName "Generic") - -to :: Qualified Ident -to = Qualified (ByModuleName DataGenericRep) (Ident "to") - -from :: Qualified Ident -from = Qualified (ByModuleName DataGenericRep) (Ident "from") - -pattern NoConstructors :: Qualified (ProperName a) -pattern NoConstructors = Qualified (ByModuleName DataGenericRep) (ProperName "NoConstructors") - -pattern NoArguments :: Qualified (ProperName a) -pattern NoArguments = Qualified (ByModuleName DataGenericRep) (ProperName "NoArguments") - -pattern Sum :: Qualified (ProperName a) -pattern Sum = Qualified (ByModuleName DataGenericRep) (ProperName "Sum") - -pattern Inl :: Qualified (ProperName a) -pattern Inl = Qualified (ByModuleName DataGenericRep) (ProperName "Inl") - -pattern Inr :: Qualified (ProperName a) -pattern Inr = Qualified (ByModuleName DataGenericRep) (ProperName "Inr") - -pattern Product :: Qualified (ProperName a) -pattern Product = Qualified (ByModuleName DataGenericRep) (ProperName "Product") - -pattern Constructor :: Qualified (ProperName a) -pattern Constructor = Qualified (ByModuleName DataGenericRep) (ProperName "Constructor") - -pattern Argument :: Qualified (ProperName a) -pattern Argument = Qualified (ByModuleName DataGenericRep) (ProperName "Argument") diff --git a/src/Language/PureScript/Constants/Data/Newtype.hs b/src/Language/PureScript/Constants/Data/Newtype.hs deleted file mode 100644 --- a/src/Language/PureScript/Constants/Data/Newtype.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Language.PureScript.Constants.Data.Newtype where - -import Language.PureScript.Names - -pattern Newtype :: Qualified (ProperName 'ClassName) -pattern Newtype = Qualified (ByModuleName (ModuleName "Data.Newtype")) (ProperName "Newtype") diff --git a/src/Language/PureScript/Constants/Data/Traversable.hs b/src/Language/PureScript/Constants/Data/Traversable.hs deleted file mode 100644 --- a/src/Language/PureScript/Constants/Data/Traversable.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Language.PureScript.Constants.Data.Traversable where - -import Data.String (IsString) -import Language.PureScript.Names - -traverse :: forall a. (IsString a) => a -traverse = "traverse" - -sequence :: forall a. (IsString a) => a -sequence = "sequence" - -pattern DataTraversable :: ModuleName -pattern DataTraversable = ModuleName "Data.Traversable" - -pattern Traversable :: Qualified (ProperName 'ClassName) -pattern Traversable = Qualified (ByModuleName DataTraversable) (ProperName "Traversable") - -identTraverse :: Qualified Ident -identTraverse = Qualified (ByModuleName DataTraversable) (Ident traverse) diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Constants/Libs.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Various constants which refer to things in the Prelude and other core libraries +module Language.PureScript.Constants.Libs where + +import qualified Protolude as P + +import Data.String (IsString) +import Language.PureScript.PSString (PSString) +import qualified Language.PureScript.Constants.TH as TH + +-- Core lib values + +stRefValue :: forall a. IsString a => a +stRefValue = "value" + +-- Type Class Dictionary Names + +data EffectDictionaries = EffectDictionaries + { edApplicativeDict :: PSString + , edBindDict :: PSString + , edMonadDict :: PSString + , edWhile :: PSString + , edUntil :: PSString + } + +effDictionaries :: EffectDictionaries +effDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeEff" + , edBindDict = "bindEff" + , edMonadDict = "monadEff" + , edWhile = "whileE" + , edUntil = "untilE" + } + +effectDictionaries :: EffectDictionaries +effectDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeEffect" + , edBindDict = "bindEffect" + , edMonadDict = "monadEffect" + , edWhile = "whileE" + , edUntil = "untilE" + } + +stDictionaries :: EffectDictionaries +stDictionaries = EffectDictionaries + { edApplicativeDict = "applicativeST" + , edBindDict = "bindST" + , edMonadDict = "monadST" + , edWhile = "while" + , edUntil = "until" + } + +$(TH.declare do + + -- purescript-prelude + + TH.mod "Control.Apply" do + TH.asIdent do TH.asString do TH.var "apply" + + TH.mod "Control.Applicative" do + TH.asIdent do TH.asPair do TH.asString do TH.var "pure" + + TH.mod "Control.Bind" do + TH.asPair do + TH.asString do + TH.var "bind" + TH.cls "Discard" ; TH.var "discard" + + TH.var "discardUnit" + + TH.mod "Control.Category" do + TH.asPair do + TH.asIdent do TH.var "identity" + + TH.var "categoryFn" + + TH.mod "Control.Semigroupoid" do + TH.asPair do + TH.vars ["compose", "composeFlipped"] + TH.var "semigroupoidFn" + + TH.mod "Data.Bounded" do + TH.asPair do + TH.vars ["bottom", "top"] + TH.var "boundedBoolean" + + TH.mod "Data.Eq" do + TH.cls "Eq" ; TH.asIdent do TH.asPair do TH.asString do TH.var "eq" + TH.cls "Eq1" ; TH.asIdent do TH.asString do TH.var "eq1" + TH.asPair do + TH.var "notEq" + + TH.var "eqBoolean" + TH.var "eqChar" + TH.var "eqInt" + TH.var "eqNumber" + TH.var "eqString" + + TH.mod "Data.EuclideanRing" do + TH.asPair do + TH.var "div" + + TH.var "euclideanRingNumber" + + TH.mod "Data.Function" do + TH.asIdent do + TH.prefixWith "function" do TH.vars ["apply", "applyFlipped"] + TH.var "const" + TH.var "flip" + + TH.mod "Data.Functor" do + TH.cls "Functor" ; TH.asIdent do TH.asString do TH.var "map" + + TH.mod "Data.Generic.Rep" do + TH.cls "Generic" ; TH.asIdent do TH.vars ["from", "to"] + TH.ntys ["Argument", "Constructor", "NoArguments", "NoConstructors", "Product"] + TH.dty "Sum" ["Inl", "Inr"] + + TH.mod "Data.HeytingAlgebra" do + TH.asPair do + TH.asIdent do TH.vars ["conj", "disj", "not"] + + TH.var "heytingAlgebraBoolean" + + TH.mod "Data.Monoid" do + TH.asIdent do TH.var "mempty" + + TH.mod "Data.Ord" do + TH.cls "Ord" ; TH.asIdent do TH.asString do TH.var "compare" + TH.cls "Ord1" ; TH.asIdent do TH.asString do TH.var "compare1" + TH.asPair do + TH.vars ["greaterThan", "greaterThanOrEq", "lessThan", "lessThanOrEq"] + + TH.var "ordBoolean" + TH.var "ordChar" + TH.var "ordInt" + TH.var "ordNumber" + TH.var "ordString" + + TH.mod "Data.Ordering" do + TH.dty "Ordering" ["EQ", "GT", "LT"] + + TH.mod "Data.Reflectable" do + TH.cls "Reflectable" + + TH.mod "Data.Ring" do + TH.asPair do + TH.asString do TH.vars ["negate", "sub"] + + TH.var "ringInt" + TH.var "ringNumber" + + TH.mod "Data.Semigroup" do + TH.asPair do + TH.asIdent do TH.var "append" + + TH.var "semigroupString" + + TH.mod "Data.Semiring" do + TH.asPair do + TH.vars ["add", "mul", "one", "zero"] + + TH.var "semiringInt" + TH.var "semiringNumber" + + TH.mod "Data.Symbol" do + TH.cls "IsSymbol" + + -- purescript-arrays + + TH.mod "Data.Array" do + TH.asPair do TH.var "unsafeIndex" + + -- purescript-bifunctors + + TH.mod "Data.Bifunctor" do + TH.cls "Bifunctor" ; TH.asIdent do TH.asString do TH.var "bimap" + TH.asIdent do TH.vars ["lmap", "rmap"] + + -- purescript-contravariant + + TH.mod "Data.Functor.Contravariant" do + TH.cls "Contravariant" ; TH.asIdent do TH.asString do TH.var "cmap" + + -- purescript-eff + + TH.mod "Control.Monad.Eff" (P.pure ()) + + TH.mod "Control.Monad.Eff.Uncurried" do + TH.asPair do TH.vars ["mkEffFn", "runEffFn"] + + -- purescript-effect + + TH.mod "Effect" (P.pure ()) + + TH.mod "Effect.Uncurried" do + TH.asPair do TH.vars ["mkEffectFn", "runEffectFn"] + + -- purescript-foldable-traversable + + TH.mod "Data.Bifoldable" do + TH.cls "Bifoldable" ; TH.asIdent do TH.asString do TH.vars ["bifoldMap", "bifoldl", "bifoldr"] + + TH.mod "Data.Bitraversable" do + TH.cls "Bitraversable" ; TH.asString do TH.asIdent (TH.var "bitraverse"); TH.var "bisequence" + TH.asIdent do + TH.vars ["ltraverse", "rtraverse"] + + TH.mod "Data.Foldable" do + TH.cls "Foldable" ; TH.asIdent do TH.asString do TH.vars ["foldMap", "foldl", "foldr"] + + TH.mod "Data.Traversable" do + TH.cls "Traversable" ; TH.asString do TH.asIdent (TH.var "traverse") ; TH.var "sequence" + + -- purescript-functions + + TH.mod "Data.Function.Uncurried" do + TH.asPair do TH.asString do TH.vars ["mkFn", "runFn"] + + -- purescript-integers + + TH.mod "Data.Int.Bits" do + TH.asPair do + TH.var "and" + TH.var "complement" + TH.var "or" + TH.var "shl" + TH.var "shr" + TH.var "xor" + TH.var "zshr" + + -- purescript-newtype + + TH.mod "Data.Newtype" do + TH.cls "Newtype" + + -- purescript-partial + + TH.mod "Partial.Unsafe" do + TH.asIdent do TH.asPair do TH.var "unsafePartial" + + -- purescript-profunctor + + TH.mod "Data.Profunctor" do + TH.cls "Profunctor" ; TH.asIdent do TH.asString do TH.var "dimap" + TH.asIdent do + TH.var "lcmap" + TH.prefixWith "profunctor" do TH.var "rmap" + + -- purescript-st + + TH.mod "Control.Monad.ST.Internal" do + TH.asPair do TH.vars ["modify", "new", "read", "run", "write"] + + TH.mod "Control.Monad.ST.Uncurried" do + TH.asPair do TH.vars ["mkSTFn", "runSTFn"] + + -- purescript-unsafe-coerce + + TH.mod "Unsafe.Coerce" do + TH.asPair do TH.var "unsafeCoerce" + + ) diff --git a/src/Language/PureScript/Constants/Prelude.hs b/src/Language/PureScript/Constants/Prelude.hs deleted file mode 100644 --- a/src/Language/PureScript/Constants/Prelude.hs +++ /dev/null @@ -1,455 +0,0 @@ --- | Various constants which refer to things in the Prelude -module Language.PureScript.Constants.Prelude where - -import Data.String (IsString) -import Language.PureScript.PSString (PSString) -import Language.PureScript.Names - --- Operators - -apply :: forall a. (IsString a) => a -apply = "apply" - -applyFlipped :: forall a. (IsString a) => a -applyFlipped = "applyFlipped" - -append :: forall a. (IsString a) => a -append = "append" - -mempty :: forall a. (IsString a) => a -mempty = "mempty" - -bind :: forall a. (IsString a) => a -bind = "bind" - -discard :: forall a. (IsString a) => a -discard = "discard" - -pattern Discard :: Qualified (ProperName 'ClassName) -pattern Discard = Qualified (ByModuleName ControlBind) (ProperName "Discard") - -add :: forall a. (IsString a) => a -add = "add" - -sub :: forall a. (IsString a) => a -sub = "sub" - -mul :: forall a. (IsString a) => a -mul = "mul" - -div :: forall a. (IsString a) => a -div = "div" - -lessThan :: forall a. (IsString a) => a -lessThan = "lessThan" - -greaterThan :: forall a. (IsString a) => a -greaterThan = "greaterThan" - -lessThanOrEq :: forall a. (IsString a) => a -lessThanOrEq = "lessThanOrEq" - -greaterThanOrEq :: forall a. (IsString a) => a -greaterThanOrEq = "greaterThanOrEq" - -eq :: forall a. (IsString a) => a -eq = "eq" - -eq1 :: forall a. (IsString a) => a -eq1 = "eq1" - -notEq :: forall a. (IsString a) => a -notEq = "notEq" - -compare :: forall a. (IsString a) => a -compare = "compare" - -compare1 :: forall a. (IsString a) => a -compare1 = "compare1" - -conj :: forall a. (IsString a) => a -conj = "conj" - -disj :: forall a. (IsString a) => a -disj = "disj" - -unsafeIndex :: forall a. (IsString a) => a -unsafeIndex = "unsafeIndex" - -or :: forall a. (IsString a) => a -or = "or" - -and :: forall a. (IsString a) => a -and = "and" - -xor :: forall a. (IsString a) => a -xor = "xor" - -compose :: forall a. (IsString a) => a -compose = "compose" - -composeFlipped :: forall a. (IsString a) => a -composeFlipped = "composeFlipped" - -map :: forall a. (IsString a) => a -map = "map" - --- Functions - -negate :: forall a. (IsString a) => a -negate = "negate" - -not :: forall a. (IsString a) => a -not = "not" - -shl :: forall a. (IsString a) => a -shl = "shl" - -shr :: forall a. (IsString a) => a -shr = "shr" - -zshr :: forall a. (IsString a) => a -zshr = "zshr" - -complement :: forall a. (IsString a) => a -complement = "complement" - -identity :: forall a. (IsString a) => a -identity = "identity" - --- Prelude Values - -zero :: forall a. (IsString a) => a -zero = "zero" - -one :: forall a. (IsString a) => a -one = "one" - -bottom :: forall a. (IsString a) => a -bottom = "bottom" - -top :: forall a. (IsString a) => a -top = "top" - -pure' :: forall a. (IsString a) => a -pure' = "pure" - --- Core lib values - -runST :: forall a. (IsString a) => a -runST = "run" - -stRefValue :: forall a. (IsString a) => a -stRefValue = "value" - -newSTRef :: forall a. (IsString a) => a -newSTRef = "new" - -readSTRef :: forall a. (IsString a) => a -readSTRef = "read" - -writeSTRef :: forall a. (IsString a) => a -writeSTRef = "write" - -modifySTRef :: forall a. (IsString a) => a -modifySTRef = "modify" - -mkFn :: forall a. (IsString a) => a -mkFn = "mkFn" - -runFn :: forall a. (IsString a) => a -runFn = "runFn" - -mkEffFn :: forall a. (IsString a) => a -mkEffFn = "mkEffFn" - -runEffFn :: forall a. (IsString a) => a -runEffFn = "runEffFn" - -mkEffectFn :: forall a. (IsString a) => a -mkEffectFn = "mkEffectFn" - -runEffectFn :: forall a. (IsString a) => a -runEffectFn = "runEffectFn" - -mkSTFn :: forall a. (IsString a) => a -mkSTFn = "mkSTFn" - -runSTFn :: forall a. (IsString a) => a -runSTFn = "runSTFn" - --- Type Class Dictionary Names - -data EffectDictionaries = EffectDictionaries - { edApplicativeDict :: PSString - , edBindDict :: PSString - , edMonadDict :: PSString - , edWhile :: PSString - , edUntil :: PSString - } - -effDictionaries :: EffectDictionaries -effDictionaries = EffectDictionaries - { edApplicativeDict = "applicativeEff" - , edBindDict = "bindEff" - , edMonadDict = "monadEff" - , edWhile = "whileE" - , edUntil = "untilE" - } - -effectDictionaries :: EffectDictionaries -effectDictionaries = EffectDictionaries - { edApplicativeDict = "applicativeEffect" - , edBindDict = "bindEffect" - , edMonadDict = "monadEffect" - , edWhile = "whileE" - , edUntil = "untilE" - } - -stDictionaries :: EffectDictionaries -stDictionaries = EffectDictionaries - { edApplicativeDict = "applicativeST" - , edBindDict = "bindST" - , edMonadDict = "monadST" - , edWhile = "while" - , edUntil = "until" - } - -discardUnitDictionary :: forall a. (IsString a) => a -discardUnitDictionary = "discardUnit" - -semiringNumber :: forall a. (IsString a) => a -semiringNumber = "semiringNumber" - -semiringInt :: forall a. (IsString a) => a -semiringInt = "semiringInt" - -ringNumber :: forall a. (IsString a) => a -ringNumber = "ringNumber" - -ringInt :: forall a. (IsString a) => a -ringInt = "ringInt" - -euclideanRingNumber :: forall a. (IsString a) => a -euclideanRingNumber = "euclideanRingNumber" - -ordBoolean :: forall a. (IsString a) => a -ordBoolean = "ordBoolean" - -ordNumber :: forall a. (IsString a) => a -ordNumber = "ordNumber" - -ordInt :: forall a. (IsString a) => a -ordInt = "ordInt" - -ordString :: forall a. (IsString a) => a -ordString = "ordString" - -ordChar :: forall a. (IsString a) => a -ordChar = "ordChar" - -eqNumber :: forall a. (IsString a) => a -eqNumber = "eqNumber" - -eqInt :: forall a. (IsString a) => a -eqInt = "eqInt" - -eqString :: forall a. (IsString a) => a -eqString = "eqString" - -eqChar :: forall a. (IsString a) => a -eqChar = "eqChar" - -eqBoolean :: forall a. (IsString a) => a -eqBoolean = "eqBoolean" - -boundedBoolean :: forall a. (IsString a) => a -boundedBoolean = "boundedBoolean" - -heytingAlgebraBoolean :: forall a. (IsString a) => a -heytingAlgebraBoolean = "heytingAlgebraBoolean" - -semigroupString :: forall a. (IsString a) => a -semigroupString = "semigroupString" - -semigroupoidFn :: forall a. (IsString a) => a -semigroupoidFn = "semigroupoidFn" - -categoryFn :: forall a. (IsString a) => a -categoryFn = "categoryFn" - --- Data.Symbol - -pattern DataSymbol :: ModuleName -pattern DataSymbol = ModuleName "Data.Symbol" - -pattern IsSymbol :: Qualified (ProperName 'ClassName) -pattern IsSymbol = Qualified (ByModuleName DataSymbol) (ProperName "IsSymbol") - -pattern DataReflectable :: ModuleName -pattern DataReflectable = ModuleName "Data.Reflectable" - -pattern Reflectable :: Qualified (ProperName 'ClassName) -pattern Reflectable = Qualified (ByModuleName DataReflectable) (ProperName "Reflectable") - -pattern DataOrdering :: ModuleName -pattern DataOrdering = ModuleName "Data.Ordering" - -pattern DataFunctionUncurried :: ModuleName -pattern DataFunctionUncurried = ModuleName "Data.Function.Uncurried" - -pattern PartialUnsafe :: ModuleName -pattern PartialUnsafe = ModuleName "Partial.Unsafe" - -pattern Ordering :: Qualified (ProperName 'TypeName) -pattern Ordering = Qualified (ByModuleName DataOrdering) (ProperName "Ordering") - -pattern LT :: Qualified (ProperName 'ConstructorName) -pattern LT = Qualified (ByModuleName DataOrdering) (ProperName "LT") - -pattern EQ :: Qualified (ProperName 'ConstructorName) -pattern EQ = Qualified (ByModuleName DataOrdering) (ProperName "EQ") - -pattern GT :: Qualified (ProperName 'ConstructorName) -pattern GT = Qualified (ByModuleName DataOrdering) (ProperName "GT") - -pattern DataArray :: ModuleName -pattern DataArray = ModuleName "Data.Array" - -pattern Eff :: ModuleName -pattern Eff = ModuleName "Control.Monad.Eff" - -pattern Effect :: ModuleName -pattern Effect = ModuleName "Effect" - -pattern ST :: ModuleName -pattern ST = ModuleName "Control.Monad.ST.Internal" - -pattern ControlApply :: ModuleName -pattern ControlApply = ModuleName "Control.Apply" - -pattern Apply :: Qualified (ProperName 'ClassName) -pattern Apply = Qualified (ByModuleName ControlApply) (ProperName "Apply") - -identApply :: Qualified Ident -identApply = Qualified (ByModuleName ControlApply) (Ident apply) - -pattern ControlApplicative :: ModuleName -pattern ControlApplicative = ModuleName "Control.Applicative" - -pattern Applicative :: Qualified (ProperName 'ClassName) -pattern Applicative = Qualified (ByModuleName ControlApplicative) (ProperName "Applicative") - -identPure :: Qualified Ident -identPure = Qualified (ByModuleName ControlApplicative) (Ident pure') - -pattern ControlSemigroupoid :: ModuleName -pattern ControlSemigroupoid = ModuleName "Control.Semigroupoid" - -pattern ControlBind :: ModuleName -pattern ControlBind = ModuleName "Control.Bind" - -pattern ControlCategory :: ModuleName -pattern ControlCategory = ModuleName "Control.Category" - -pattern Category :: Qualified (ProperName 'ClassName) -pattern Category = Qualified (ByModuleName ControlCategory) (ProperName "Category") - -identIdentity :: Qualified Ident -identIdentity = Qualified (ByModuleName ControlCategory) (Ident identity) - -pattern ControlMonadEffUncurried :: ModuleName -pattern ControlMonadEffUncurried = ModuleName "Control.Monad.Eff.Uncurried" - -pattern EffectUncurried :: ModuleName -pattern EffectUncurried = ModuleName "Effect.Uncurried" - -pattern ControlMonadSTUncurried :: ModuleName -pattern ControlMonadSTUncurried = ModuleName "Control.Monad.ST.Uncurried" - -pattern DataBounded :: ModuleName -pattern DataBounded = ModuleName "Data.Bounded" - -pattern DataSemigroup :: ModuleName -pattern DataSemigroup = ModuleName "Data.Semigroup" - -identAppend :: Qualified Ident -identAppend = Qualified (ByModuleName DataSemigroup) (Ident append) - -pattern DataMonoid :: ModuleName -pattern DataMonoid = ModuleName "Data.Monoid" - -identMempty :: Qualified Ident -identMempty = Qualified (ByModuleName DataMonoid) (Ident mempty) - -pattern DataHeytingAlgebra :: ModuleName -pattern DataHeytingAlgebra = ModuleName "Data.HeytingAlgebra" - -pattern DataEq :: ModuleName -pattern DataEq = ModuleName "Data.Eq" - -pattern Eq :: Qualified (ProperName 'ClassName) -pattern Eq = Qualified (ByModuleName DataEq) (ProperName "Eq") - -pattern Eq1 :: Qualified (ProperName 'ClassName) -pattern Eq1 = Qualified (ByModuleName DataEq) (ProperName "Eq1") - -identEq :: Qualified Ident -identEq = Qualified (ByModuleName DataEq) (Ident eq) - -identEq1 :: Qualified Ident -identEq1 = Qualified (ByModuleName DataEq) (Ident eq1) - -pattern DataOrd :: ModuleName -pattern DataOrd = ModuleName "Data.Ord" - -pattern Ord :: Qualified (ProperName 'ClassName) -pattern Ord = Qualified (ByModuleName DataOrd) (ProperName "Ord") - -pattern Ord1 :: Qualified (ProperName 'ClassName) -pattern Ord1 = Qualified (ByModuleName DataOrd) (ProperName "Ord1") - -identCompare :: Qualified Ident -identCompare = Qualified (ByModuleName DataOrd) (Ident compare) - -identCompare1 :: Qualified Ident -identCompare1 = Qualified (ByModuleName DataOrd) (Ident compare1) - -pattern DataFunctor :: ModuleName -pattern DataFunctor = ModuleName "Data.Functor" - -pattern Functor :: Qualified (ProperName 'ClassName) -pattern Functor = Qualified (ByModuleName DataFunctor) (ProperName "Functor") - -identMap :: Qualified Ident -identMap = Qualified (ByModuleName DataFunctor) (Ident map) - -pattern DataSemiring :: ModuleName -pattern DataSemiring = ModuleName "Data.Semiring" - -pattern DataRing :: ModuleName -pattern DataRing = ModuleName "Data.Ring" - -pattern DataEuclideanRing :: ModuleName -pattern DataEuclideanRing = ModuleName "Data.EuclideanRing" - -pattern DataFunction :: ModuleName -pattern DataFunction = ModuleName "Data.Function" - -identFlip :: Qualified Ident -identFlip = Qualified (ByModuleName DataFunction) (Ident flip) - -flip :: forall a. (IsString a) => a -flip = "flip" - -pattern DataIntBits :: ModuleName -pattern DataIntBits = ModuleName "Data.Int.Bits" - -unsafePartial :: forall a. (IsString a) => a -unsafePartial = "unsafePartial" - -pattern UnsafeCoerce :: ModuleName -pattern UnsafeCoerce = ModuleName "Unsafe.Coerce" - -unsafeCoerceFn :: forall a. (IsString a) => a -unsafeCoerceFn = "unsafeCoerce" diff --git a/src/Language/PureScript/Constants/Prim.hs b/src/Language/PureScript/Constants/Prim.hs --- a/src/Language/PureScript/Constants/Prim.hs +++ b/src/Language/PureScript/Constants/Prim.hs @@ -1,195 +1,57 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} -- | Various constants which refer to things in Prim module Language.PureScript.Constants.Prim where -import Data.String (IsString) import Language.PureScript.Names - --- Prim values - -undefined :: forall a. (IsString a) => a -undefined = "undefined" - --- Prim - -pattern Prim :: ModuleName -pattern Prim = ModuleName "Prim" - -pattern Partial :: Qualified (ProperName 'ClassName) -pattern Partial = Qualified (ByModuleName Prim) (ProperName "Partial") - -pattern Record :: Qualified (ProperName 'TypeName) -pattern Record = Qualified (ByModuleName Prim) (ProperName "Record") - -pattern Type :: Qualified (ProperName 'TypeName) -pattern Type = Qualified (ByModuleName Prim) (ProperName "Type") - -pattern Constraint :: Qualified (ProperName 'TypeName) -pattern Constraint = Qualified (ByModuleName Prim) (ProperName "Constraint") - -pattern Function :: Qualified (ProperName 'TypeName) -pattern Function = Qualified (ByModuleName Prim) (ProperName "Function") - -pattern Array :: Qualified (ProperName 'TypeName) -pattern Array = Qualified (ByModuleName Prim) (ProperName "Array") - -pattern Row :: Qualified (ProperName 'TypeName) -pattern Row = Qualified (ByModuleName Prim) (ProperName "Row") - --- Prim.Boolean - -pattern PrimBoolean :: ModuleName -pattern PrimBoolean = ModuleName "Prim.Boolean" - -booleanTrue :: Qualified (ProperName 'TypeName) -booleanTrue = Qualified (ByModuleName PrimBoolean) (ProperName "True") - -booleanFalse :: Qualified (ProperName 'TypeName) -booleanFalse = Qualified (ByModuleName PrimBoolean) (ProperName "False") - --- Prim.Coerce - -pattern PrimCoerce :: ModuleName -pattern PrimCoerce = ModuleName "Prim.Coerce" - -pattern Coercible :: Qualified (ProperName 'ClassName) -pattern Coercible = Qualified (ByModuleName PrimCoerce) (ProperName "Coercible") - --- Prim.Ordering - -pattern PrimOrdering :: ModuleName -pattern PrimOrdering = ModuleName "Prim.Ordering" - -orderingLT :: Qualified (ProperName 'TypeName) -orderingLT = Qualified (ByModuleName PrimOrdering) (ProperName "LT") - -orderingEQ :: Qualified (ProperName 'TypeName) -orderingEQ = Qualified (ByModuleName PrimOrdering) (ProperName "EQ") - -orderingGT :: Qualified (ProperName 'TypeName) -orderingGT = Qualified (ByModuleName PrimOrdering) (ProperName "GT") - --- Prim.Row - -pattern PrimRow :: ModuleName -pattern PrimRow = ModuleName "Prim.Row" - -pattern RowUnion :: Qualified (ProperName 'ClassName) -pattern RowUnion = Qualified (ByModuleName PrimRow) (ProperName "Union") - -pattern RowNub :: Qualified (ProperName 'ClassName) -pattern RowNub = Qualified (ByModuleName PrimRow) (ProperName "Nub") - -pattern RowCons :: Qualified (ProperName 'ClassName) -pattern RowCons = Qualified (ByModuleName PrimRow) (ProperName "Cons") - -pattern RowLacks :: Qualified (ProperName 'ClassName) -pattern RowLacks = Qualified (ByModuleName PrimRow) (ProperName "Lacks") - --- Prim.RowList - -pattern PrimRowList :: ModuleName -pattern PrimRowList = ModuleName "Prim.RowList" - -pattern RowToList :: Qualified (ProperName 'ClassName) -pattern RowToList = Qualified (ByModuleName PrimRowList) (ProperName "RowToList") - -pattern RowListNil :: Qualified (ProperName 'TypeName) -pattern RowListNil = Qualified (ByModuleName PrimRowList) (ProperName "Nil") - -pattern RowListCons :: Qualified (ProperName 'TypeName) -pattern RowListCons = Qualified (ByModuleName PrimRowList) (ProperName "Cons") - --- Prim.Int - -pattern PrimInt :: ModuleName -pattern PrimInt = ModuleName "Prim.Int" - -pattern IntAdd :: Qualified (ProperName 'ClassName) -pattern IntAdd = Qualified (ByModuleName PrimInt) (ProperName "Add") - -pattern IntCompare :: Qualified (ProperName 'ClassName) -pattern IntCompare = Qualified (ByModuleName PrimInt) (ProperName "Compare") - -pattern IntMul :: Qualified (ProperName 'ClassName) -pattern IntMul = Qualified (ByModuleName PrimInt) (ProperName "Mul") - -pattern IntToString :: Qualified (ProperName 'ClassName) -pattern IntToString = Qualified (ByModuleName PrimInt) (ProperName "ToString") +import qualified Language.PureScript.Constants.TH as TH --- Prim.Symbol +$(TH.declare do + TH.mod "Prim" do + TH.cls "Partial" + TH.ty "Array" + TH.ty "Boolean" + TH.ty "Char" + TH.ty "Constraint" + TH.ty "Function" + TH.ty "Int" + TH.ty "Number" + TH.ty "Record" + TH.ty "Row" + TH.ty "String" + TH.ty "Symbol" + TH.ty "Type" + TH.asIdent do TH.asString do TH.var "undefined" -pattern PrimSymbol :: ModuleName -pattern PrimSymbol = ModuleName "Prim.Symbol" + TH.mod "Prim.Boolean" do + TH.tys ["False", "True"] -pattern SymbolCompare :: Qualified (ProperName 'ClassName) -pattern SymbolCompare = Qualified (ByModuleName PrimSymbol) (ProperName "Compare") + TH.mod "Prim.Coerce" do + TH.cls "Coercible" -pattern SymbolAppend :: Qualified (ProperName 'ClassName) -pattern SymbolAppend = Qualified (ByModuleName PrimSymbol) (ProperName "Append") + TH.mod "Prim.Int" do + TH.prefixWith "Int" do TH.clss ["Add", "Compare", "Mul", "ToString"] -pattern SymbolCons :: Qualified (ProperName 'ClassName) -pattern SymbolCons = Qualified (ByModuleName PrimSymbol) (ProperName "Cons") + TH.mod "Prim.Ordering" do + TH.prefixWith "Type" do TH.ty "Ordering" + TH.tys ["EQ", "GT", "LT"] --- Prim.TypeError + TH.mod "Prim.Row" do + TH.prefixWith "Row" do TH.clss ["Cons", "Lacks", "Nub", "Union"] + + TH.mod "Prim.RowList" do + TH.ty "RowList" + TH.cls "RowToList" + TH.prefixWith "RowList" do TH.tys ["Cons", "Nil"] -pattern PrimTypeError :: ModuleName -pattern PrimTypeError = ModuleName "Prim.TypeError" + TH.mod "Prim.Symbol" do + TH.prefixWith "Symbol" do TH.clss ["Append", "Compare", "Cons"] -pattern Fail :: Qualified (ProperName 'ClassName) -pattern Fail = Qualified (ByModuleName PrimTypeError) (ProperName "Fail") + TH.mod "Prim.TypeError" do + TH.clss ["Fail", "Warn"] + TH.tys ["Above", "Beside", "Doc", "Quote", "QuoteLabel", "Text"] -pattern Warn :: Qualified (ProperName 'ClassName) -pattern Warn = Qualified (ByModuleName PrimTypeError) (ProperName "Warn") + ) primModules :: [ModuleName] -primModules = [Prim, PrimBoolean, PrimCoerce, PrimOrdering, PrimRow, PrimRowList, PrimSymbol, PrimInt, PrimTypeError] - -typ :: forall a. (IsString a) => a -typ = "Type" - -kindOrdering :: forall a. (IsString a) => a -kindOrdering = "Ordering" - -kindRowList :: forall a. (IsString a) => a -kindRowList = "RowList" - -symbol :: forall a. (IsString a) => a -symbol = "Symbol" - -doc :: forall a. (IsString a) => a -doc = "Doc" - -row :: forall a. (IsString a) => a -row = "Row" - -constraint :: forall a. (IsString a) => a -constraint = "Constraint" - --- Modules - -prim :: forall a. (IsString a) => a -prim = "Prim" - -moduleBoolean :: forall a. (IsString a) => a -moduleBoolean = "Boolean" - -moduleCoerce :: forall a. (IsString a) => a -moduleCoerce = "Coerce" - -moduleOrdering :: forall a. (IsString a) => a -moduleOrdering = "Ordering" - -moduleRow :: forall a. (IsString a) => a -moduleRow = "Row" - -moduleRowList :: forall a. (IsString a) => a -moduleRowList = "RowList" - -moduleSymbol :: forall a. (IsString a) => a -moduleSymbol = "Symbol" - -moduleInt :: forall a. (IsString a) => a -moduleInt = "Int" - -typeError :: forall a. (IsString a) => a -typeError = "TypeError" +primModules = [M_Prim, M_Prim_Boolean, M_Prim_Coerce, M_Prim_Ordering, M_Prim_Row, M_Prim_RowList, M_Prim_Symbol, M_Prim_Int, M_Prim_TypeError] diff --git a/src/Language/PureScript/Constants/TH.hs b/src/Language/PureScript/Constants/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Constants/TH.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This module implements an eDSL for compactly declaring pattern synonyms +-- representing known PureScript modules and their members. +-- +-- The following example assumes this module is imported qualified as TH and +-- the BlockArguments extension is used, both of which I recommend. +-- +-- > $(TH.declare do +-- > TH.mod "Data.Foo" do +-- > TH.ty "SomeType" +-- > TH.asIdent do +-- > TH.var "someVariable" +-- > ) +-- +-- will become: +-- +-- > pattern M_Data_Foo :: ModuleName +-- > pattern M_Data_Foo = ModuleName "Data.Foo" +-- > +-- > pattern SomeType :: Qualified (ProperName 'TypeName) +-- > pattern SomeType = Qualified (ByModuleName M_Data_Foo) (ProperName "SomeType") +-- > +-- > pattern I_someVariable :: Qualified Ident +-- > pattern I_someVariable = Qualified (ByModuleName M_Data_Foo) (Ident "someVariable") +-- +-- All pattern synonyms must start with an uppercase letter. To prevent +-- namespace collisions, different types of pattern are distinguished by a sort +-- of Hungarian notation convention: +-- +-- @ +-- SomeType -- a type or class name +-- C_Ctor -- a constructor name +-- I_name -- a Qualified Ident +-- M_Data_Foo -- a module name +-- P_name -- a (module name, polymorphic string) pair +-- S_name -- a lone polymorphic string (this doesn't contain any module information) +-- @ +-- +-- I_, P_, and S_ patterns are all optional and have to be enabled with +-- `asIdent`, `asPair`, and `asString` modifiers respectively. +-- +-- Finally, to disambiguate between identifiers with the same name (such as +-- Data.Function.apply and Data.Apply.apply), the `prefixWith` modifier will +-- modify the names of the patterns created within it. +-- +-- > TH.mod "Data.Function" do +-- > TH.prefixWith "function" do +-- > TH.asIdent do +-- > TH.var "apply" +-- +-- results in: +-- +-- > pattern I_functionApply :: Qualified Ident +-- > pattern I_functionApply = Qualified (ByModuleName (M_Data_Function) (Ident "apply") +-- +module Language.PureScript.Constants.TH + ( declare + , mod + , cls, clss + , dty + , nty, ntys + , ty, tys + , var, vars + , prefixWith + , asIdent + , asPair + , asString + ) where + +import Protolude hiding (Type, mod) + +import Control.Lens (over, _head) +import Control.Monad.Trans.RWS (RWS, execRWS) +import Control.Monad.Trans.Writer (Writer, execWriter) +import Control.Monad.Writer.Class (tell) +import Data.String (String) +import Language.Haskell.TH +import Language.PureScript.Names hiding (Name) + +-- | Generate pattern synonyms corresponding to the provided PureScript +-- declarations. +declare :: Writer (Q [Dec]) () -> Q [Dec] +declare = execWriter + +-- | Declare a module. +mod :: String -> ModDecs -> Writer (Q [Dec]) () +mod mnStr inner = do + -- pattern M_Data_Foo :: ModuleName + -- pattern M_Data_Foo = ModuleName "Data.Foo" + let mn = mkModuleName mnStr + tell $ typedPatSyn mn [t| ModuleName |] [p| ModuleName $(litP $ stringL mnStr) |] + tell $ snd $ execRWS inner (mn, "", []) () + +-- | Declare a type class. The resulting pattern will use the name of the class +-- and have type `Qualified (ProperName 'ClassName)`. +cls :: String -> ModDecs +cls cn = ask >>= \(mn, prefix, _) -> tell $ mkPnPat [t| 'ClassName |] mn prefix cn + +-- | Declare a list of type classes; shorthand for repeatedly calling `cls`. +clss :: [String] -> ModDecs +clss = traverse_ cls + +-- | Declare a data type, given the name of the type and a list of constructor +-- names. A pattern will be created using the name of the type and have type +-- `Qualified (ProperName 'TypeName)`. A pattern will also be created for each +-- constructor prefixed with "C_", having type `Qualified (ProperName +-- 'ConstructorName)`. +dty :: String -> [String] -> ModDecs +dty dn ctors = ask >>= \(mn, prefix, _) -> do + tell $ mkPnPat [t| 'TypeName |] mn prefix dn + tell $ map fold $ traverse (mkPnPat [t| 'ConstructorName |] mn $ "C_" <> prefix) ctors + +-- | Declare a data type with a singular constructor named the same as the +-- type, as is commonly the case with newtypes (but this does not require the +-- type to be a newtype in reality). Shorthand for calling `dty`. +nty :: String -> ModDecs +nty tn = dty tn [tn] + +-- | Declare a list of data types with singular constructors; shorthand for +-- repeatedly calling `nty`, which itself is shorthand for `dty`. +ntys :: [String] -> ModDecs +ntys = traverse_ nty + +-- | Declare a type. The resulting pattern will use the name of the type and have +-- type `Qualified (ProperName 'TypeName)`. +ty :: String -> ModDecs +ty tn = ask >>= \(mn, prefix, _) -> tell $ mkPnPat [t| 'TypeName |] mn prefix tn + +-- | Declare a list of types; shorthand for repeatedly calling `ty`. +tys :: [String] -> ModDecs +tys = traverse_ ty + +-- | Declare a variable, function, named instance, or generally a lower-case +-- value member of a module. The patterns created depend on which of `asPair`, +-- `asIdent`, or `asString` are used in the enclosing context. +var :: String -> ModDecs +var nm = ask >>= \(mn, prefix, vtds) -> tell $ foldMap (\f -> f mn prefix nm) vtds + +-- | Declare a list of variables; shorthand for repeatedly calling `var`. +vars :: [String] -> ModDecs +vars = traverse_ var + +-- | For every variable declared within, create a pattern synonym prefixed +-- with "P_" having type `forall a. (Eq a, IsString a) => (ModuleName, a)`. +asPair :: ModDecs -> ModDecs +asPair = local $ addToVars mkPairDec + +-- | For every variable declared within, cerate a pattern synonym prefixed +-- with "I_" having type `Qualified Ident`. +asIdent :: ModDecs -> ModDecs +asIdent = local $ addToVars mkIdentDec + +-- | For every variable declared within, cerate a pattern synonym prefixed +-- with "S_" having type `forall a. (Eq a, IsString a) => a`. +asString :: ModDecs -> ModDecs +asString = local $ addToVars mkStringDec + +-- | Prefix the names of all enclosed declarations with the provided string, to +-- prevent collisions with other identifiers. For example, +-- `prefixWith "function"` would turn `I_apply` into `I_functionApply`, and +-- `C_Example` into `C_FunctionExample`. +prefixWith :: String -> ModDecs -> ModDecs +prefixWith = local . applyPrefix + +-- Internals start here + +type ModDecs = RWS (Name, String, [VarToDec]) (Q [Dec]) () () +type VarToDec = Name -> String -> String -> Q [Dec] + +addToVars :: VarToDec -> (a, b, [VarToDec]) -> (a, b, [VarToDec]) +addToVars f (a, b, fs) = (a, b, f : fs) + +applyPrefix :: String -> (a, String, c) -> (a, String, c) +applyPrefix prefix (a, prefix', c) = (a, camelAppend prefix' prefix, c) + +cap :: String -> String +cap = over _head toUpper + +camelAppend :: String -> String -> String +camelAppend l r = if null l then r else l <> cap r + +-- "Data.Foo" -> M_Data_Foo +mkModuleName :: String -> Name +mkModuleName = mkName . ("M_" <>) . map (\case '.' -> '_'; other -> other) + +-- "I_" -> "fn" -> "foo" -> I_fnFoo +-- "I_" -> "" -> "foo" -> I_foo +mkPrefixedName :: String -> String -> String -> Name +mkPrefixedName tag prefix = mkName . (tag <>) . camelAppend prefix + +-- 'TypeName -> M_Data_Foo -> "Function" -> "Foo" -> +-- pattern FunctionFoo :: Qualified (ProperName 'TypeName) +-- pattern FunctionFoo = Qualified (ByModuleName M_Data_Foo) (ProperName "Foo") +mkPnPat :: Q Type -> VarToDec +mkPnPat pnType mn prefix str = typedPatSyn (mkName $ cap prefix <> str) + [t| Qualified (ProperName $pnType) |] + [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str)) |] + +-- M_Data_Foo -> "function" -> "foo" -> +-- pattern I_functionFoo :: Qualified Ident +-- pattern I_functionFoo = Qualified (ByModuleName M_Data_Foo) (Ident "foo") +mkIdentDec :: VarToDec +mkIdentDec mn prefix str = typedPatSyn (mkPrefixedName "I_" prefix str) + [t| Qualified Ident |] + [p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) |] + +-- M_Data_Foo -> "function" -> "foo" -> +-- pattern P_functionFoo :: forall a. (Eq a, IsString a) => (ModuleName, a) +-- pattern P_functionFoo = (M_Data_Foo, "foo") +mkPairDec :: VarToDec +mkPairDec mn prefix str = typedPatSyn (mkPrefixedName "P_" prefix str) + [t| forall a. (Eq a, IsString a) => (ModuleName, a) |] + [p| ($(conP mn []), $(litP $ stringL str)) |] + +-- _ -> "function" -> "foo" -> +-- pattern S_functionFoo :: forall a. (Eq a, IsString a) => a +-- pattern S_functionFoo = "foo" +mkStringDec :: VarToDec +mkStringDec _ prefix str = typedPatSyn (mkPrefixedName "S_" prefix str) + [t| forall a. (Eq a, IsString a) => a |] + (litP $ stringL str) + +typedPatSyn :: Name -> Q Type -> Q Pat -> Q [Dec] +typedPatSyn nm t p = sequence [patSynSigD nm t, patSynD nm (prefixPatSyn []) implBidir p] diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -19,7 +19,7 @@ import Language.PureScript.AST.Literals import Language.PureScript.AST.SourcePos (nullSourceSpan) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Binders import Language.PureScript.CoreFn.Expr diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -109,7 +109,7 @@ A.Unused{} -> True _ -> False exprToCoreFn ss com ty (A.Unused _) = - Var (ss, com, ty, Nothing) (Qualified (ByModuleName C.Prim) (Ident C.undefined)) + Var (ss, com, ty, Nothing) C.I_undefined exprToCoreFn _ com ty (A.Var ss ident) = Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -17,7 +17,7 @@ import qualified Data.Set as S import Language.PureScript.AST.SourcePos -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import Language.PureScript.CoreFn import Language.PureScript.Crash import Language.PureScript.Names @@ -128,8 +128,7 @@ Var a i -> f delay force a i Abs a i e -> Abs a i <$> snd (if force == Just 0 then go (succ delay) force else go delay $ fmap pred force) e -- A clumsy hack to preserve TCO in a particular idiom of unsafePartial once seen in Data.Map.Internal, possibly still used elsewhere. - App a1 e1@(Var _ (Qualified (ByModuleName C.PartialUnsafe) (Ident up))) (Abs a2 i e2) | up == C.unsafePartial - -> App a1 e1 . Abs a2 i <$> handleExpr' e2 + App a1 e1@(Var _ C.I_unsafePartial) (Abs a2 i e2) -> App a1 e1 . Abs a2 i <$> handleExpr' e2 App a e1 e2 -> -- `handleApp` is just to handle the constructor application exception -- somewhat gracefully (i.e., without requiring a deep inspection of @@ -533,7 +532,7 @@ nullAnn = ssAnn nullSourceSpan runtimeLazy = Var nullAnn . Qualified ByNullSourcePos $ InternalIdent RuntimeLazyFactory - runFn3 = Var nullAnn . Qualified (ByModuleName C.DataFunctionUncurried) . Ident $ C.runFn <> "3" + runFn3 = Var nullAnn . Qualified (ByModuleName C.M_Data_Function_Uncurried) . Ident $ C.S_runFn <> "3" strLit = Literal nullAnn . StringLiteral . mkString lazifyIdent = \case diff --git a/src/Language/PureScript/CoreFn/Optimizer.hs b/src/Language/PureScript/CoreFn/Optimizer.hs --- a/src/Language/PureScript/CoreFn/Optimizer.hs +++ b/src/Language/PureScript/CoreFn/Optimizer.hs @@ -11,10 +11,9 @@ import Language.PureScript.CoreFn.Expr import Language.PureScript.CoreFn.Module import Language.PureScript.CoreFn.Traversals -import Language.PureScript.Names (Ident(..), QualifiedBy(..), Qualified(..)) import Language.PureScript.Label import Language.PureScript.Types -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import qualified Language.PureScript.Constants.Prim as C -- | @@ -54,7 +53,7 @@ optimizeDataFunctionApply :: Expr a -> Expr a optimizeDataFunctionApply e = case e of - (App a (App _ (Var _ (Qualified (ByModuleName C.DataFunction) (Ident fn))) x) y) - | fn == C.apply -> App a x y - | fn == C.applyFlipped -> App a y x + (App a (App _ (Var _ fn) x) y) + | C.I_functionApply <- fn -> App a x y + | C.I_functionApplyFlipped <- fn -> App a y x _ -> e diff --git a/src/Language/PureScript/CoreImp/Optimizer/Common.hs b/src/Language/PureScript/CoreImp/Optimizer/Common.hs --- a/src/Language/PureScript/CoreImp/Optimizer/Common.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Common.hs @@ -60,10 +60,13 @@ removeFromBlock go (Block ss sts) = Block ss (go sts) removeFromBlock _ js = js -isDict :: (ModuleName, PSString) -> AST -> Bool -isDict (moduleName, dictName) (ModuleAccessor _ x y) = - x == moduleName && y == dictName -isDict _ _ = False +pattern Ref :: (ModuleName, PSString) -> AST +pattern Ref pair <- (refPatternHelper -> Just pair) +-- ideally: pattern Ref (moduleName, refName) <- ModuleAccessor _ moduleName refName +-- but: https://gitlab.haskell.org/ghc/ghc/-/issues/12203 +-- https://github.com/ghc-proposals/ghc-proposals/pull/138 -isDict' :: [(ModuleName, PSString)] -> AST -> Bool -isDict' xs js = any (`isDict` js) xs +refPatternHelper :: AST -> Maybe (ModuleName, PSString) +refPatternHelper = \case + ModuleAccessor _ moduleName refName -> Just (moduleName, refName) + _ -> Nothing diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs --- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs @@ -18,16 +18,15 @@ import Data.Either (rights) import Data.Maybe (fromMaybe) -import Data.String (IsString, fromString) import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Names (ModuleName) -import Language.PureScript.PSString (PSString) +import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.CoreImp.AST import Language.PureScript.CoreImp.Optimizer.Common import Language.PureScript.AST (SourceSpan(..)) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import qualified Language.PureScript.Constants.Prim as C -- TODO: Potential bug: @@ -72,7 +71,7 @@ convert :: AST -> AST convert (App _ (Function _ Nothing [] (Block _ [Return _ ret])) []) = ret convert (App _ (Function _ Nothing idents (Block _ [Return ss ret])) []) - | not (any (`isReassigned` ret) idents) = replaceIdents (map (, Var ss C.undefined) idents) ret + | not (any (`isReassigned` ret) idents) = replaceIdents (map (, Var ss C.S_undefined) idents) ret convert js = js inlineVariables :: AST -> AST @@ -89,129 +88,121 @@ inlineCommonValues expander = everywhere convert where convert :: AST -> AST - convert (expander -> App ss fn [dict]) - | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0) - | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1) - | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False - | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True - convert (App ss (expander -> App _ fn [dict]) [x]) - | isDict ringInt dict && isDict fnNegate fn = Binary ss BitwiseOr (Unary ss Negate x) (NumericLiteral ss (Left 0)) - convert (App ss (App _ (expander -> App _ fn [dict]) [x]) [y]) - | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add x y - | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply x y - | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract x y + convert (expander -> App ss (Ref fn) [Ref dict]) + | dict `elem` [C.P_semiringNumber, C.P_semiringInt], C.P_zero <- fn = NumericLiteral ss (Left 0) + | dict `elem` [C.P_semiringNumber, C.P_semiringInt], C.P_one <- fn = NumericLiteral ss (Left 1) + | C.P_boundedBoolean <- dict, C.P_bottom <- fn = BooleanLiteral ss False + | C.P_boundedBoolean <- dict, C.P_top <- fn = BooleanLiteral ss True + convert (App ss (expander -> App _ (Ref C.P_negate) [Ref C.P_ringInt]) [x]) + = Binary ss BitwiseOr (Unary ss Negate x) (NumericLiteral ss (Left 0)) + convert (App ss (App _ (expander -> App _ (Ref fn) [Ref dict]) [x]) [y]) + | C.P_semiringInt <- dict, C.P_add <- fn = intOp ss Add x y + | C.P_semiringInt <- dict, C.P_mul <- fn = intOp ss Multiply x y + | C.P_ringInt <- dict, C.P_sub <- fn = intOp ss Subtract x y convert other = other - fnZero = (C.DataSemiring, C.zero) - fnOne = (C.DataSemiring, C.one) - fnBottom = (C.DataBounded, C.bottom) - fnTop = (C.DataBounded, C.top) - fnAdd = (C.DataSemiring, C.add) - fnMultiply = (C.DataSemiring, C.mul) - fnSubtract = (C.DataRing, C.sub) - fnNegate = (C.DataRing, C.negate) intOp ss op x y = Binary ss BitwiseOr (Binary ss op x y) (NumericLiteral ss (Left 0)) inlineCommonOperators :: (AST -> AST) -> AST -> AST inlineCommonOperators expander = everywhereTopDown $ applyAll $ - [ binary semiringNumber opAdd Add - , binary semiringNumber opMul Multiply + [ binary C.P_semiringNumber C.P_add Add + , binary C.P_semiringNumber C.P_mul Multiply - , binary ringNumber opSub Subtract - , unary ringNumber opNegate Negate + , binary C.P_ringNumber C.P_sub Subtract + , unary C.P_ringNumber C.P_negate Negate - , binary euclideanRingNumber opDiv Divide + , binary C.P_euclideanRingNumber C.P_div Divide - , binary eqNumber opEq EqualTo - , binary eqNumber opNotEq NotEqualTo - , binary eqInt opEq EqualTo - , binary eqInt opNotEq NotEqualTo - , binary eqString opEq EqualTo - , binary eqString opNotEq NotEqualTo - , binary eqChar opEq EqualTo - , binary eqChar opNotEq NotEqualTo - , binary eqBoolean opEq EqualTo - , binary eqBoolean opNotEq NotEqualTo + , binary C.P_eqNumber C.P_eq EqualTo + , binary C.P_eqNumber C.P_notEq NotEqualTo + , binary C.P_eqInt C.P_eq EqualTo + , binary C.P_eqInt C.P_notEq NotEqualTo + , binary C.P_eqString C.P_eq EqualTo + , binary C.P_eqString C.P_notEq NotEqualTo + , binary C.P_eqChar C.P_eq EqualTo + , binary C.P_eqChar C.P_notEq NotEqualTo + , binary C.P_eqBoolean C.P_eq EqualTo + , binary C.P_eqBoolean C.P_notEq NotEqualTo - , binary ordBoolean opLessThan LessThan - , binary ordBoolean opLessThanOrEq LessThanOrEqualTo - , binary ordBoolean opGreaterThan GreaterThan - , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo - , binary ordChar opLessThan LessThan - , binary ordChar opLessThanOrEq LessThanOrEqualTo - , binary ordChar opGreaterThan GreaterThan - , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo - , binary ordInt opLessThan LessThan - , binary ordInt opLessThanOrEq LessThanOrEqualTo - , binary ordInt opGreaterThan GreaterThan - , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo - , binary ordNumber opLessThan LessThan - , binary ordNumber opLessThanOrEq LessThanOrEqualTo - , binary ordNumber opGreaterThan GreaterThan - , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo - , binary ordString opLessThan LessThan - , binary ordString opLessThanOrEq LessThanOrEqualTo - , binary ordString opGreaterThan GreaterThan - , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordBoolean C.P_lessThan LessThan + , binary C.P_ordBoolean C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordBoolean C.P_greaterThan GreaterThan + , binary C.P_ordBoolean C.P_greaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordChar C.P_lessThan LessThan + , binary C.P_ordChar C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordChar C.P_greaterThan GreaterThan + , binary C.P_ordChar C.P_greaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordInt C.P_lessThan LessThan + , binary C.P_ordInt C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordInt C.P_greaterThan GreaterThan + , binary C.P_ordInt C.P_greaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordNumber C.P_lessThan LessThan + , binary C.P_ordNumber C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordNumber C.P_greaterThan GreaterThan + , binary C.P_ordNumber C.P_greaterThanOrEq GreaterThanOrEqualTo + , binary C.P_ordString C.P_lessThan LessThan + , binary C.P_ordString C.P_lessThanOrEq LessThanOrEqualTo + , binary C.P_ordString C.P_greaterThan GreaterThan + , binary C.P_ordString C.P_greaterThanOrEq GreaterThanOrEqualTo - , binary semigroupString opAppend Add + , binary C.P_semigroupString C.P_append Add - , binary heytingAlgebraBoolean opConj And - , binary heytingAlgebraBoolean opDisj Or - , unary heytingAlgebraBoolean opNot Not + , binary C.P_heytingAlgebraBoolean C.P_conj And + , binary C.P_heytingAlgebraBoolean C.P_disj Or + , unary C.P_heytingAlgebraBoolean C.P_not Not - , binary' C.DataIntBits C.or BitwiseOr - , binary' C.DataIntBits C.and BitwiseAnd - , binary' C.DataIntBits C.xor BitwiseXor - , binary' C.DataIntBits C.shl ShiftLeft - , binary' C.DataIntBits C.shr ShiftRight - , binary' C.DataIntBits C.zshr ZeroFillShiftRight - , unary' C.DataIntBits C.complement BitwiseNot + , binary' C.P_or BitwiseOr + , binary' C.P_and BitwiseAnd + , binary' C.P_xor BitwiseXor + , binary' C.P_shl ShiftLeft + , binary' C.P_shr ShiftRight + , binary' C.P_zshr ZeroFillShiftRight + , unary' C.P_complement BitwiseNot - , inlineNonClassFunction (isModFnWithDict (C.DataArray, C.unsafeIndex)) $ flip (Indexer Nothing) + , inlineNonClassFunction (isModFnWithDict C.P_unsafeIndex) $ flip (Indexer Nothing) ] ++ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.ControlMonadEffUncurried C.mkEffFn i, runEffFn C.ControlMonadEffUncurried C.runEffFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.EffectUncurried C.mkEffectFn i, runEffFn C.EffectUncurried C.runEffectFn i ] ] ++ - [ fn | i <- [0..10], fn <- [ mkEffFn C.ControlMonadSTUncurried C.mkSTFn i, runEffFn C.ControlMonadSTUncurried C.runSTFn i ] ] + [ fn | i <- [0..10], fn <- [ mkEffFn C.P_mkEffFn i, runEffFn C.P_runEffFn i ] ] ++ + [ fn | i <- [0..10], fn <- [ mkEffFn C.P_mkEffectFn i, runEffFn C.P_runEffectFn i ] ] ++ + [ fn | i <- [0..10], fn <- [ mkEffFn C.P_mkSTFn i, runEffFn C.P_runSTFn i ] ] where binary :: (ModuleName, PSString) -> (ModuleName, PSString) -> BinaryOperator -> AST -> AST - binary dict fns op = convert where + binary dict fn op = convert where convert :: AST -> AST - convert (App ss (App _ (expander -> App _ fn [dict']) [x]) [y]) | isDict dict dict' && isDict fns fn = Binary ss op x y + convert (App ss (App _ (expander -> App _ (Ref fn') [Ref dict']) [x]) [y]) | dict == dict', fn == fn' = Binary ss op x y convert other = other - binary' :: ModuleName -> PSString -> BinaryOperator -> AST -> AST - binary' moduleName opString op = convert where + binary' :: (ModuleName, PSString) -> BinaryOperator -> AST -> AST + binary' fn op = convert where convert :: AST -> AST - convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op x y + convert (App ss (App _ (Ref fn') [x]) [y]) | fn == fn' = Binary ss op x y convert other = other unary :: (ModuleName, PSString) -> (ModuleName, PSString) -> UnaryOperator -> AST -> AST - unary dicts fns op = convert where + unary dict fn op = convert where convert :: AST -> AST - convert (App ss (expander -> App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op x + convert (App ss (expander -> App _ (Ref fn') [Ref dict']) [x]) | dict == dict', fn == fn' = Unary ss op x convert other = other - unary' :: ModuleName -> PSString -> UnaryOperator -> AST -> AST - unary' moduleName fnName op = convert where + unary' :: (ModuleName, PSString) -> UnaryOperator -> AST -> AST + unary' fn op = convert where convert :: AST -> AST - convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op x + convert (App ss (Ref fn') [x]) | fn == fn' = Unary ss op x convert other = other mkFn :: Int -> AST -> AST - mkFn = mkFn' C.DataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args js -> + mkFn = mkFn' C.P_mkFn $ \ss1 ss2 ss3 args js -> Function ss1 Nothing args (Block ss2 [Return ss3 js]) - mkEffFn :: ModuleName -> Text -> Int -> AST -> AST - mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args js -> + mkEffFn :: (ModuleName, PSString) -> Int -> AST -> AST + mkEffFn mkFn_ = mkFn' mkFn_ $ \ss1 ss2 ss3 args js -> Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 js [])]) - mkFn' :: ModuleName -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST - mkFn' modName fnName res 0 = convert where + mkFn' :: (ModuleName, PSString) -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST + mkFn' mkFn_ res 0 = convert where convert :: AST -> AST - convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 js])]) | isNFn modName fnName 0 mkFnN = + convert (App _ (Ref mkFnN) [Function s1 Nothing [_] (Block s2 [Return s3 js])]) | isNFn mkFn_ 0 mkFnN = res s1 s2 s3 [] js convert other = other - mkFn' modName fnName res n = convert where + mkFn' mkFn_ res n = convert where convert :: AST -> AST - convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN = + convert orig@(App ss (Ref mkFnN) [fn]) | isNFn mkFn_ n mkFnN = case collectArgs n [] fn of Just (args, [Return ss' ret]) -> res ss ss ss' args ret _ -> orig @@ -221,25 +212,23 @@ collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret collectArgs _ _ _ = Nothing - isNFn :: ModuleName -> Text -> Int -> AST -> Bool - isNFn expectMod prefix n (ModuleAccessor _ modName name) | modName == expectMod = - name == fromString (T.unpack prefix <> show n) - isNFn _ _ _ _ = False + isNFn :: (ModuleName, PSString) -> Int -> (ModuleName, PSString) -> Bool + isNFn prefix n fn = fmap (<> mkString (T.pack $ show n)) prefix == fn runFn :: Int -> AST -> AST - runFn = runFn' C.DataFunctionUncurried C.runFn App + runFn = runFn' C.P_runFn App - runEffFn :: ModuleName -> Text -> Int -> AST -> AST - runEffFn modName fnName = runFn' modName fnName $ \ss fn acc -> + runEffFn :: (ModuleName, PSString) -> Int -> AST -> AST + runEffFn runFn_ = runFn' runFn_ $ \ss fn acc -> Function ss Nothing [] (Block ss [Return ss (App ss fn acc)]) - runFn' :: ModuleName -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST - runFn' modName runFnName res n = convert where + runFn' :: (ModuleName, PSString) -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST + runFn' runFn_ res n = convert where convert :: AST -> AST convert js = fromMaybe js $ go n [] js go :: Int -> [AST] -> AST -> Maybe AST - go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n = + go 0 acc (App ss (Ref runFnN) [fn]) | isNFn runFn_ n runFnN && length acc == n = Just $ res ss fn acc go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs go _ _ _ = Nothing @@ -251,8 +240,7 @@ convert other = other isModFnWithDict :: (ModuleName, PSString) -> AST -> Bool - isModFnWithDict (m, op) (App _ (ModuleAccessor _ m' op') [Var _ _]) = - m == m' && op == op' + isModFnWithDict fn (App _ (Ref fn') [Var _ _]) = fn == fn' isModFnWithDict _ _ = False -- (f <<< g $ x) = f (g x) @@ -261,11 +249,11 @@ inlineFnComposition expander = everywhereTopDownM convert where convert :: AST -> m AST - convert (App s1 (App s2 (App _ (expander -> App _ fn [dict']) [x]) [y]) [z]) - | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]] - | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]] - convert app@(App ss (App _ (expander -> App _ fn [dict']) _) _) - | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName + convert (App s1 (App s2 (App _ (expander -> App _ (Ref fn) [Ref C.P_semigroupoidFn]) [x]) [y]) [z]) + | C.P_compose <- fn = return $ App s1 x [App s2 y [z]] + | C.P_composeFlipped <- fn = return $ App s2 y [App s1 x [z]] + convert app@(App ss (App _ (expander -> App _ (Ref fn) [Ref C.P_semigroupoidFn]) _) _) + | fn `elem` [C.P_compose, C.P_composeFlipped] = mkApps ss <$> goApps app <*> freshName convert other = return other mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST @@ -279,151 +267,28 @@ mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name goApps :: AST -> m [Either AST (Text, AST)] - goApps (App _ (App _ (expander -> App _ fn [dict']) [x]) [y]) - | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y - | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x + goApps (App _ (App _ (expander -> App _ (Ref fn) [Ref C.P_semigroupoidFn]) [x]) [y]) + | C.P_compose <- fn = mappend <$> goApps x <*> goApps y + | C.P_composeFlipped <- fn = mappend <$> goApps y <*> goApps x goApps app@App {} = pure . Right . (,app) <$> freshName goApps other = pure [Left other] - isFnCompose :: AST -> AST -> Bool - isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn - - isFnComposeFlipped :: AST -> AST -> Bool - isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn - - fnCompose :: forall a. IsString a => (ModuleName, a) - fnCompose = (C.ControlSemigroupoid, C.compose) - - fnComposeFlipped :: forall a. IsString a => (ModuleName, a) - fnComposeFlipped = (C.ControlSemigroupoid, C.composeFlipped) - inlineFnIdentity :: (AST -> AST) -> AST -> AST inlineFnIdentity expander = everywhereTopDown convert where convert :: AST -> AST - convert (App _ (expander -> App _ fn [dict]) [x]) | isDict categoryFn dict && isDict fnIdentity fn = x + convert (App _ (expander -> App _ (Ref C.P_identity) [Ref C.P_categoryFn]) [x]) = x convert other = other - fnIdentity :: forall a. IsString a => (ModuleName, a) - fnIdentity = (C.ControlCategory, C.identity) - inlineUnsafeCoerce :: AST -> AST inlineUnsafeCoerce = everywhereTopDown convert where - convert (App _ (ModuleAccessor _ C.UnsafeCoerce unsafeCoerceFn) [ comp ]) - | unsafeCoerceFn == C.unsafeCoerceFn - = comp + convert (App _ (Ref C.P_unsafeCoerce) [ comp ]) = comp convert other = other inlineUnsafePartial :: AST -> AST inlineUnsafePartial = everywhereTopDown convert where - convert (App ss (ModuleAccessor _ C.PartialUnsafe unsafePartial) [ comp ]) - | unsafePartial == C.unsafePartial + convert (App ss (Ref C.P_unsafePartial) [ comp ]) -- Apply to undefined here, the application should be optimized away -- if it is safe to do so - = App ss comp [ Var ss C.undefined ] + = App ss comp [ Var ss C.S_undefined ] convert other = other - -semiringNumber :: forall a. IsString a => (ModuleName, a) -semiringNumber = (C.DataSemiring, C.semiringNumber) - -semiringInt :: forall a. IsString a => (ModuleName, a) -semiringInt = (C.DataSemiring, C.semiringInt) - -ringNumber :: forall a. IsString a => (ModuleName, a) -ringNumber = (C.DataRing, C.ringNumber) - -ringInt :: forall a. IsString a => (ModuleName, a) -ringInt = (C.DataRing, C.ringInt) - -euclideanRingNumber :: forall a. IsString a => (ModuleName, a) -euclideanRingNumber = (C.DataEuclideanRing, C.euclideanRingNumber) - -eqNumber :: forall a. IsString a => (ModuleName, a) -eqNumber = (C.DataEq, C.eqNumber) - -eqInt :: forall a. IsString a => (ModuleName, a) -eqInt = (C.DataEq, C.eqInt) - -eqString :: forall a. IsString a => (ModuleName, a) -eqString = (C.DataEq, C.eqString) - -eqChar :: forall a. IsString a => (ModuleName, a) -eqChar = (C.DataEq, C.eqChar) - -eqBoolean :: forall a. IsString a => (ModuleName, a) -eqBoolean = (C.DataEq, C.eqBoolean) - -ordBoolean :: forall a. IsString a => (ModuleName, a) -ordBoolean = (C.DataOrd, C.ordBoolean) - -ordNumber :: forall a. IsString a => (ModuleName, a) -ordNumber = (C.DataOrd, C.ordNumber) - -ordInt :: forall a. IsString a => (ModuleName, a) -ordInt = (C.DataOrd, C.ordInt) - -ordString :: forall a. IsString a => (ModuleName, a) -ordString = (C.DataOrd, C.ordString) - -ordChar :: forall a. IsString a => (ModuleName, a) -ordChar = (C.DataOrd, C.ordChar) - -semigroupString :: forall a. IsString a => (ModuleName, a) -semigroupString = (C.DataSemigroup, C.semigroupString) - -boundedBoolean :: forall a. IsString a => (ModuleName, a) -boundedBoolean = (C.DataBounded, C.boundedBoolean) - -heytingAlgebraBoolean :: forall a. IsString a => (ModuleName, a) -heytingAlgebraBoolean = (C.DataHeytingAlgebra, C.heytingAlgebraBoolean) - -semigroupoidFn :: forall a. IsString a => (ModuleName, a) -semigroupoidFn = (C.ControlSemigroupoid, C.semigroupoidFn) - -categoryFn :: forall a. IsString a => (ModuleName, a) -categoryFn = (C.ControlCategory, C.categoryFn) - -opAdd :: forall a. IsString a => (ModuleName, a) -opAdd = (C.DataSemiring, C.add) - -opMul :: forall a. IsString a => (ModuleName, a) -opMul = (C.DataSemiring, C.mul) - -opEq :: forall a. IsString a => (ModuleName, a) -opEq = (C.DataEq, C.eq) - -opNotEq :: forall a. IsString a => (ModuleName, a) -opNotEq = (C.DataEq, C.notEq) - -opLessThan :: forall a. IsString a => (ModuleName, a) -opLessThan = (C.DataOrd, C.lessThan) - -opLessThanOrEq :: forall a. IsString a => (ModuleName, a) -opLessThanOrEq = (C.DataOrd, C.lessThanOrEq) - -opGreaterThan :: forall a. IsString a => (ModuleName, a) -opGreaterThan = (C.DataOrd, C.greaterThan) - -opGreaterThanOrEq :: forall a. IsString a => (ModuleName, a) -opGreaterThanOrEq = (C.DataOrd, C.greaterThanOrEq) - -opAppend :: forall a. IsString a => (ModuleName, a) -opAppend = (C.DataSemigroup, C.append) - -opSub :: forall a. IsString a => (ModuleName, a) -opSub = (C.DataRing, C.sub) - -opNegate :: forall a. IsString a => (ModuleName, a) -opNegate = (C.DataRing, C.negate) - -opDiv :: forall a. IsString a => (ModuleName, a) -opDiv = (C.DataEuclideanRing, C.div) - -opConj :: forall a. IsString a => (ModuleName, a) -opConj = (C.DataHeytingAlgebra, C.conj) - -opDisj :: forall a. IsString a => (ModuleName, a) -opDisj = (C.DataHeytingAlgebra, C.disj) - -opNot :: forall a. IsString a => (ModuleName, a) -opNot = (C.DataHeytingAlgebra, C.not) diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs --- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs @@ -11,7 +11,7 @@ import Language.PureScript.CoreImp.Optimizer.Common import Language.PureScript.Names (ModuleName) import Language.PureScript.PSString (mkString) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | Inline type class dictionaries for >>= and return for the Eff monad -- @@ -28,13 +28,13 @@ -- ... -- } magicDoEff :: (AST -> AST) -> AST -> AST -magicDoEff = magicDo C.Eff C.effDictionaries +magicDoEff = magicDo C.M_Control_Monad_Eff C.effDictionaries magicDoEffect :: (AST -> AST) -> AST -> AST -magicDoEffect = magicDo C.Effect C.effectDictionaries +magicDoEffect = magicDo C.M_Effect C.effectDictionaries magicDoST :: (AST -> AST) -> AST -> AST -magicDoST = magicDo C.ST C.stDictionaries +magicDoST = magicDo C.M_Control_Monad_ST_Internal C.stDictionaries magicDo :: ModuleName -> C.EffectDictionaries -> (AST -> AST) -> AST -> AST magicDo effectModule C.EffectDictionaries{..} expander = everywhereTopDown convert @@ -68,25 +68,16 @@ App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) [] convert other = other -- Check if an expression represents a monomorphic call to >>= for the Eff monad - isBind (expander -> App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True + isBind (expander -> App _ (Ref C.P_bind) [Ref dict]) = (effectModule, edBindDict) == dict isBind _ = False -- Check if an expression represents a call to @discard@ - isDiscard (expander -> App _ (expander -> App _ fn [dict1]) [dict2]) - | isDict (C.ControlBind, C.discardUnitDictionary) dict1 && - isDict (effectModule, edBindDict) dict2 && - isDiscardPoly fn = True + isDiscard (expander -> App _ (expander -> App _ (Ref C.P_discard) [Ref C.P_discardUnit]) [Ref dict]) = (effectModule, edBindDict) == dict isDiscard _ = False -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative - isPure (expander -> App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True + isPure (expander -> App _ (Ref C.P_pure) [Ref dict]) = (effectModule, edApplicativeDict) == dict isPure _ = False - -- Check if an expression represents the polymorphic >>= function - isBindPoly = isDict (C.ControlBind, C.bind) - -- Check if an expression represents the polymorphic pure function - isPurePoly = isDict (C.ControlApplicative, C.pure') - -- Check if an expression represents the polymorphic discard function - isDiscardPoly = isDict (C.ControlBind, C.discard) -- Check if an expression represents a function in the Effect module - isEffFunc name (ModuleAccessor _ eff name') = eff == effectModule && name == name' + isEffFunc name (Ref fn) = (effectModule, name) == fn isEffFunc _ _ = False applyReturns :: AST -> AST @@ -102,10 +93,10 @@ inlineST :: AST -> AST inlineST = everywhere convertBlock where - -- Look for runST blocks and inline the STRefs there. - -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then + -- Look for run blocks and inline the STRefs there. + -- If all STRefs are used in the scope of the same run, only using { read, write, modify } then -- we can be more aggressive about inlining, and actually turn STRefs into local variables. - convertBlock (App s1 f [arg]) | isSTFunc C.runST f = + convertBlock (App s1 (Ref C.P_run) [arg]) = let refs = ordNub . findSTRefsIn $ arg usages = findAllSTUsagesIn arg allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages @@ -115,28 +106,25 @@ -- Convert a block in a safe way, preserving object wrappers of references, -- or in a more aggressive way, turning wrappers into local variables depending on the -- agg(ressive) parameter. - convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f = + convert agg (App s1 (Ref C.P_new) [arg]) = Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]]) - convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f = + convert agg (App _ (App s1 (Ref C.P_read) [ref]) []) = if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref - convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f = + convert agg (App _ (App _ (App s1 (Ref C.P_write) [arg]) [ref]) []) = if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg - convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f = + convert agg (App _ (App _ (App s1 (Ref C.P_modify) [func]) [ref]) []) = if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref]) convert _ other = other - -- Check if an expression represents a function in the ST module - isSTFunc name (ModuleAccessor _ C.ST name') = name == name' - isSTFunc _ _ = False -- Find all ST Refs initialized in this block findSTRefsIn = everything (++) isSTRef where - isSTRef (VariableIntroduction _ ident (Just (_, App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident] + isSTRef (VariableIntroduction _ ident (Just (_, App _ (App _ (Ref C.P_new) [_]) []))) = [ident] isSTRef _ = [] - -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef + -- Find all STRefs used as arguments to read, write, modify findAllSTUsagesIn = everything (++) isSTUsage where - isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref] - isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref] + isSTUsage (App _ (App _ (Ref C.P_read) [ref]) []) = [ref] + isSTUsage (App _ (App _ (App _ (Ref f) [_]) [ref]) []) | f `elem` [C.P_write, C.P_modify] = [ref] isSTUsage _ = [] -- Find all uses of a variable appearingIn ref = everything (++) isVar diff --git a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs --- a/src/Language/PureScript/CoreImp/Optimizer/Unused.hs +++ b/src/Language/PureScript/CoreImp/Optimizer/Unused.hs @@ -32,7 +32,7 @@ removeUndefinedApp :: AST -> AST removeUndefinedApp = everywhere convert where - convert (App ss fn [Var _ arg]) | arg == C.undefined = App ss fn [] + convert (App ss fn [Var _ C.S_undefined]) = App ss fn [] convert js = js removeUnusedEffectFreeVars :: [Text] -> [[AST]] -> [[AST]] diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -147,8 +147,7 @@ where collect - :: (Eq a, Show a) - => (P.ModuleName -> a -> m (P.ModuleName, [b])) + :: (P.ModuleName -> a -> m (P.ModuleName, [b])) -> Map a P.ExportSource -> m (Map P.ModuleName [b]) collect lookup' exps = do diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -13,6 +13,7 @@ import qualified Data.Map as Map import Language.PureScript.Docs.Types +import qualified Language.PureScript.Constants.Prim as P import qualified Language.PureScript.Crash as P import qualified Language.PureScript.Environment as P import qualified Language.PureScript.Names as P @@ -158,27 +159,23 @@ , modReExports = [] } -type NameGen a = Text -> P.Qualified (P.ProperName a) - -unsafeLookupOf +unsafeLookup :: forall v (a :: P.ProperNameType) - . NameGen a - -> Map.Map (P.Qualified (P.ProperName a)) v + . Map.Map (P.Qualified (P.ProperName a)) v -> String - -> Text + -> P.Qualified (P.ProperName a) -> v -unsafeLookupOf k m errorMsg name = go name +unsafeLookup m errorMsg name = go name where - go = fromJust' . flip Map.lookup m . k + go = fromJust' . flip Map.lookup m fromJust' (Just x) = x - fromJust' _ = P.internalError $ errorMsg ++ show name + fromJust' _ = P.internalError $ errorMsg ++ show (P.runProperName $ P.disqualify name) -lookupPrimTypeKindOf - :: NameGen 'P.TypeName - -> Text +lookupPrimTypeKind + :: P.Qualified (P.ProperName 'P.TypeName) -> Type' -lookupPrimTypeKindOf k = ($> ()) . fst . unsafeLookupOf k +lookupPrimTypeKind = ($> ()) . fst . unsafeLookup ( P.primTypes <> P.primBooleanTypes <> P.primOrderingTypes <> @@ -187,23 +184,20 @@ P.primTypeErrorTypes ) "Docs.Prim: No such Prim type: " -primType :: Text -> Text -> Declaration -primType = primTypeOf P.primName - -primTypeOf :: NameGen 'P.TypeName -> Text -> Text -> Declaration -primTypeOf gen title comments = Declaration - { declTitle = title +primType :: P.Qualified (P.ProperName 'P.TypeName) -> Text -> Declaration +primType tn comments = Declaration + { declTitle = P.runProperName $ P.disqualify tn , declComments = Just comments , declSourceSpan = Nothing , declChildren = [] - , declInfo = ExternDataDeclaration (lookupPrimTypeKindOf gen title) [] + , declInfo = ExternDataDeclaration (lookupPrimTypeKind tn) [] , declKind = Nothing } -- | Lookup the TypeClassData of a Prim class. This function is specifically -- not exported because it is partial. -lookupPrimClassOf :: NameGen 'P.ClassName -> Text -> P.TypeClassData -lookupPrimClassOf g = unsafeLookupOf g +lookupPrimClass :: P.Qualified (P.ProperName 'P.ClassName) -> P.TypeClassData +lookupPrimClass = unsafeLookup ( P.primClasses <> P.primCoerceClasses <> P.primRowClasses <> @@ -213,18 +207,15 @@ P.primTypeErrorClasses ) "Docs.Prim: No such Prim class: " -primClass :: Text -> Text -> Declaration -primClass = primClassOf P.primName - -primClassOf :: NameGen 'P.ClassName -> Text -> Text -> Declaration -primClassOf gen title comments = Declaration - { declTitle = title +primClass :: P.Qualified (P.ProperName 'P.ClassName) -> Text -> Declaration +primClass cn comments = Declaration + { declTitle = P.runProperName $ P.disqualify cn , declComments = Just comments , declSourceSpan = Nothing , declChildren = [] , declInfo = let - tcd = lookupPrimClassOf gen title + tcd = lookupPrimClass cn args = fmap (fmap ($> ())) <$> P.typeClassArguments tcd superclasses = ($> ()) <$> P.typeClassSuperclasses tcd fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) @@ -234,13 +225,13 @@ } kindType :: Declaration -kindType = primType "Type" $ T.unlines +kindType = primType P.Type $ T.unlines [ "`Type` is the kind of all proper types: those that classify value-level terms." , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`." ] kindConstraint :: Declaration -kindConstraint = primType "Constraint" $ T.unlines +kindConstraint = primType P.Constraint $ T.unlines [ "`Constraint` is the kind of type class constraints." , "For example, a type class declaration like this:" , "" @@ -253,7 +244,7 @@ ] kindSymbol :: Declaration -kindSymbol = primType "Symbol" $ T.unlines +kindSymbol = primType P.Symbol $ T.unlines [ "`Symbol` is the kind of type-level strings." , "" , "Construct types of this kind using the same literal syntax as documented" @@ -265,7 +256,7 @@ ] kindRow :: Declaration -kindRow = primType "Row" $ T.unlines +kindRow = primType P.Row $ T.unlines [ "`Row` is the kind constructor of label-indexed types which map type-level strings to other types." , "The most common use of `Row` is `Row Type`, a row mapping labels to basic (of kind `Type`) types:" , "" @@ -277,7 +268,7 @@ ] function :: Declaration -function = primType "Function" $ T.unlines +function = primType P.Function $ T.unlines [ "A function, which takes values of the type specified by the first type" , "parameter, and returns values of the type specified by the second." , "In the JavaScript backend, this is a standard JavaScript Function." @@ -296,7 +287,7 @@ ] array :: Declaration -array = primType "Array" $ T.unlines +array = primType P.Array $ T.unlines [ "An Array: a data structure supporting efficient random access. In" , "the JavaScript backend, values of this type are represented as JavaScript" , "Arrays at runtime." @@ -307,7 +298,7 @@ ] record :: Declaration -record = primType "Record" $ T.unlines +record = primType P.Record $ T.unlines [ "The type of records whose fields are known at compile time. In the" , "JavaScript backend, values of this type are represented as JavaScript" , "Objects at runtime." @@ -329,7 +320,7 @@ ] number :: Declaration -number = primType "Number" $ T.unlines +number = primType P.Number $ T.unlines [ "A double precision floating point number (IEEE 754)." , "" , "Construct values of this type with literals." @@ -342,7 +333,7 @@ ] int :: Declaration -int = primType "Int" $ T.unlines +int = primType P.Int $ T.unlines [ "A 32-bit signed integer. See the `purescript-integers` package for details" , "of how this is accomplished when compiling to JavaScript." , "" @@ -375,7 +366,7 @@ ] string :: Declaration -string = primType "String" $ T.unlines +string = primType P.String $ T.unlines [ "A String. As in JavaScript, String values represent sequences of UTF-16" , "code units, which are not required to form a valid encoding of Unicode" , "text (for example, lone surrogates are permitted)." @@ -397,7 +388,7 @@ ] char :: Declaration -char = primType "Char" $ T.unlines +char = primType P.Char $ T.unlines [ "A single character (UTF-16 code unit). The JavaScript representation is a" , "normal `String`, which is guaranteed to contain one code unit. This means" , "that astral plane characters (i.e. those with code point values greater" @@ -409,7 +400,7 @@ ] boolean :: Declaration -boolean = primType "Boolean" $ T.unlines +boolean = primType P.Boolean $ T.unlines [ "A JavaScript Boolean value." , "" , "Construct values of this type with the literals `true` and `false`." @@ -418,7 +409,7 @@ ] partial :: Declaration -partial = primClass "Partial" $ T.unlines +partial = primClass P.Partial $ T.unlines [ "The Partial type class is used to indicate that a function is *partial,*" , "that is, it is not defined for all inputs. In practice, attempting to use" , "a partial function with a bad input will usually cause an error to be" @@ -428,17 +419,17 @@ ] booleanTrue :: Declaration -booleanTrue = primTypeOf (P.primSubName "Boolean") "True" $ T.unlines +booleanTrue = primType P.True $ T.unlines [ "The 'True' boolean type." ] booleanFalse :: Declaration -booleanFalse = primTypeOf (P.primSubName "Boolean") "False" $ T.unlines +booleanFalse = primType P.False $ T.unlines [ "The 'False' boolean type." ] coercible :: Declaration -coercible = primClassOf (P.primSubName "Coerce") "Coercible" $ T.unlines +coercible = primClass P.Coercible $ T.unlines [ "Coercible is a two-parameter type class that has instances for types `a`" , "and `b` if the compiler can infer that they have the same representation." , "Coercible constraints are solved according to the following rules:" @@ -494,29 +485,29 @@ ] kindOrdering :: Declaration -kindOrdering = primTypeOf (P.primSubName "Ordering") "Ordering" $ T.unlines +kindOrdering = primType P.TypeOrdering $ T.unlines [ "The `Ordering` kind represents the three possibilities of comparing two" , "types of the same kind: `LT` (less than), `EQ` (equal to), and" , "`GT` (greater than)." ] orderingLT :: Declaration -orderingLT = primTypeOf (P.primSubName "Ordering") "LT" $ T.unlines +orderingLT = primType P.LT $ T.unlines [ "The 'less than' ordering type." ] orderingEQ :: Declaration -orderingEQ = primTypeOf (P.primSubName "Ordering") "EQ" $ T.unlines +orderingEQ = primType P.EQ $ T.unlines [ "The 'equal to' ordering type." ] orderingGT :: Declaration -orderingGT = primTypeOf (P.primSubName "Ordering") "GT" $ T.unlines +orderingGT = primType P.GT $ T.unlines [ "The 'greater than' ordering type." ] union :: Declaration -union = primClassOf (P.primSubName "Row") "Union" $ T.unlines +union = primClass P.RowUnion $ T.unlines [ "The Union type class is used to compute the union of two rows of types" , "(left-biased, including duplicates)." , "" @@ -524,58 +515,58 @@ ] nub :: Declaration -nub = primClassOf (P.primSubName "Row") "Nub" $ T.unlines +nub = primClass P.RowNub $ T.unlines [ "The Nub type class is used to remove duplicate labels from rows." ] lacks :: Declaration -lacks = primClassOf (P.primSubName "Row") "Lacks" $ T.unlines +lacks = primClass P.RowLacks $ T.unlines [ "The Lacks type class asserts that a label does not occur in a given row." ] rowCons :: Declaration -rowCons = primClassOf (P.primSubName "Row") "Cons" $ T.unlines +rowCons = primClass P.RowCons $ T.unlines [ "The Cons type class is a 4-way relation which asserts that one row of" , "types can be obtained from another by inserting a new label/type pair on" , "the left." ] kindRowList :: Declaration -kindRowList = primTypeOf (P.primSubName "RowList") "RowList" $ T.unlines +kindRowList = primType P.RowList $ T.unlines [ "A type level list representation of a row of types." ] rowListCons :: Declaration -rowListCons = primTypeOf (P.primSubName "RowList") "Cons" $ T.unlines +rowListCons = primType P.RowListCons $ T.unlines [ "Constructs a new `RowList` from a label, a type, and an existing tail" , "`RowList`. E.g: `Cons \"x\" Int (Cons \"y\" Int Nil)`." ] rowListNil :: Declaration -rowListNil = primTypeOf (P.primSubName "RowList") "Nil" $ T.unlines +rowListNil = primType P.RowListNil $ T.unlines [ "The empty `RowList`." ] rowToList :: Declaration -rowToList = primClassOf (P.primSubName "RowList") "RowToList" $ T.unlines +rowToList = primClass P.RowToList $ T.unlines [ "Compiler solved type class for generating a `RowList` from a closed row" , "of types. Entries are sorted by label and duplicates are preserved in" , "the order they appeared in the row." ] symbolAppend :: Declaration -symbolAppend = primClassOf (P.primSubName "Symbol") "Append" $ T.unlines +symbolAppend = primClass P.SymbolAppend $ T.unlines [ "Compiler solved type class for appending `Symbol`s together." ] symbolCompare :: Declaration -symbolCompare = primClassOf (P.primSubName "Symbol") "Compare" $ T.unlines +symbolCompare = primClass P.SymbolCompare $ T.unlines [ "Compiler solved type class for comparing two `Symbol`s." , "Produces an `Ordering`." ] symbolCons :: Declaration -symbolCons = primClassOf (P.primSubName "Symbol") "Cons" $ T.unlines +symbolCons = primClass P.SymbolCons $ T.unlines [ "Compiler solved type class for either splitting up a symbol into its" , "head and tail or for combining a head and tail into a new symbol." , "Requires the head to be a single character and the combined string" @@ -583,28 +574,28 @@ ] intAdd :: Declaration -intAdd = primClassOf (P.primSubName "Int") "Add" $ T.unlines +intAdd = primClass P.IntAdd $ T.unlines [ "Compiler solved type class for adding type-level `Int`s." ] intCompare :: Declaration -intCompare = primClassOf (P.primSubName "Int") "Compare" $ T.unlines +intCompare = primClass P.IntCompare $ T.unlines [ "Compiler solved type class for comparing two type-level `Int`s." , "Produces an `Ordering`." ] intMul :: Declaration -intMul = primClassOf (P.primSubName "Int") "Mul" $ T.unlines +intMul = primClass P.IntMul $ T.unlines [ "Compiler solved type class for multiplying type-level `Int`s." ] intToString :: Declaration -intToString = primClassOf (P.primSubName "Int") "ToString" $ T.unlines +intToString = primClass P.IntToString $ T.unlines [ "Compiler solved type class for converting a type-level `Int` into a type-level `String` (i.e. `Symbol`)." ] fail :: Declaration -fail = primClassOf (P.primSubName "TypeError") "Fail" $ T.unlines +fail = primClass P.Fail $ T.unlines [ "The Fail type class is part of the custom type errors feature. To provide" , "a custom type error when someone tries to use a particular instance," , "write that instance out with a Fail constraint." @@ -614,7 +605,7 @@ ] warn :: Declaration -warn = primClassOf (P.primSubName "TypeError") "Warn" $ T.unlines +warn = primClass P.Warn $ T.unlines [ "The Warn type class allows a custom compiler warning to be displayed." , "" , "For more information, see" @@ -622,7 +613,7 @@ ] kindDoc :: Declaration -kindDoc = primTypeOf (P.primSubName "TypeError") "Doc" $ T.unlines +kindDoc = primType P.Doc $ T.unlines [ "`Doc` is the kind of type-level documents." , "" , "This kind is used with the `Fail` and `Warn` type classes." @@ -630,7 +621,7 @@ ] textDoc :: Declaration -textDoc = primTypeOf (P.primSubName "TypeError") "Text" $ T.unlines +textDoc = primType P.Text $ T.unlines [ "The Text type constructor makes a Doc from a Symbol" , "to be used in a custom type error." , "" @@ -639,7 +630,7 @@ ] quoteDoc :: Declaration -quoteDoc = primTypeOf (P.primSubName "TypeError") "Quote" $ T.unlines +quoteDoc = primType P.Quote $ T.unlines [ "The Quote type constructor renders any concrete type as a Doc" , "to be used in a custom type error." , "" @@ -648,7 +639,7 @@ ] quoteLabelDoc :: Declaration -quoteLabelDoc = primTypeOf (P.primSubName "TypeError") "QuoteLabel" $ T.unlines +quoteLabelDoc = primType P.QuoteLabel $ T.unlines [ "The `QuoteLabel` type constructor will produce a `Doc` when given a `Symbol`. When the resulting `Doc` is rendered" , "for a `Warn` or `Fail` constraint, a syntactically valid label will be produced, escaping with quotes as needed." , "" @@ -657,7 +648,7 @@ ] besideDoc :: Declaration -besideDoc = primTypeOf (P.primSubName "TypeError") "Beside" $ T.unlines +besideDoc = primType P.Beside $ T.unlines [ "The Beside type constructor combines two Docs horizontally" , "to be used in a custom type error." , "" @@ -666,7 +657,7 @@ ] aboveDoc :: Declaration -aboveDoc = primTypeOf (P.primSubName "TypeError") "Above" $ T.unlines +aboveDoc = primType P.Above $ T.unlines [ "The Above type constructor combines two Docs vertically" , "in a custom type error." , "" diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -9,6 +9,7 @@ import Data.Aeson ((.=), (.:)) import qualified Data.Aeson as A import Data.Foldable (find, fold) +import Data.Functor ((<&>)) import qualified Data.IntMap as IM import qualified Data.IntSet as IS import qualified Data.Map as M @@ -279,81 +280,62 @@ "newtype" -> return Newtype other -> fail $ "invalid type: '" ++ T.unpack other ++ "'" --- | Construct a ProperName in the Prim module -primName :: Text -> Qualified (ProperName a) -primName = Qualified (ByModuleName C.Prim) . ProperName - --- | Construct a 'ProperName' in the @Prim.NAME@ module. -primSubName :: Text -> Text -> Qualified (ProperName a) -primSubName sub = - Qualified (ByModuleName $ ModuleName $ C.prim <> "." <> sub) . ProperName - -primKind :: Text -> SourceType -primKind = primTy - -primSubKind :: Text -> Text -> SourceType -primSubKind sub = TypeConstructor nullSourceAnn . primSubName sub - -- | Kind of ground types kindType :: SourceType -kindType = primKind C.typ +kindType = srcTypeConstructor C.Type kindConstraint :: SourceType -kindConstraint = primKind C.constraint +kindConstraint = srcTypeConstructor C.Constraint kindSymbol :: SourceType -kindSymbol = primKind C.symbol +kindSymbol = srcTypeConstructor C.Symbol kindDoc :: SourceType -kindDoc = primSubKind C.typeError C.doc +kindDoc = srcTypeConstructor C.Doc kindOrdering :: SourceType -kindOrdering = primSubKind C.moduleOrdering C.kindOrdering +kindOrdering = srcTypeConstructor C.TypeOrdering kindRowList :: SourceType -> SourceType -kindRowList = TypeApp nullSourceAnn (primSubKind C.moduleRowList C.kindRowList) +kindRowList = TypeApp nullSourceAnn (srcTypeConstructor C.RowList) kindRow :: SourceType -> SourceType -kindRow = TypeApp nullSourceAnn (primKind C.row) +kindRow = TypeApp nullSourceAnn (srcTypeConstructor C.Row) kindOfREmpty :: SourceType kindOfREmpty = tyForall "k" kindType (kindRow (tyVar "k")) --- | Construct a type in the Prim module -primTy :: Text -> SourceType -primTy = TypeConstructor nullSourceAnn . primName - -- | Type constructor for functions tyFunction :: SourceType -tyFunction = primTy "Function" +tyFunction = srcTypeConstructor C.Function -- | Type constructor for strings tyString :: SourceType -tyString = primTy "String" +tyString = srcTypeConstructor C.String -- | Type constructor for strings tyChar :: SourceType -tyChar = primTy "Char" +tyChar = srcTypeConstructor C.Char -- | Type constructor for numbers tyNumber :: SourceType -tyNumber = primTy "Number" +tyNumber = srcTypeConstructor C.Number -- | Type constructor for integers tyInt :: SourceType -tyInt = primTy "Int" +tyInt = srcTypeConstructor C.Int -- | Type constructor for booleans tyBoolean :: SourceType -tyBoolean = primTy "Boolean" +tyBoolean = srcTypeConstructor C.Boolean -- | Type constructor for arrays tyArray :: SourceType -tyArray = primTy "Array" +tyArray = srcTypeConstructor C.Array -- | Type constructor for records tyRecord :: SourceType -tyRecord = primTy "Record" +tyRecord = srcTypeConstructor C.Record tyVar :: Text -> SourceType tyVar = TypeVar nullSourceAnn @@ -370,12 +352,12 @@ (-:>) = function infixr 4 -:> -primClass :: Qualified (ProperName 'TypeName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))] +primClass :: Qualified (ProperName 'ClassName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))] primClass name mkKind = [ let k = mkKind kindConstraint - in (name, (k, ExternData (nominalRolesForKind k))) + in (coerceProperName <$> name, (k, ExternData (nominalRolesForKind k))) , let k = mkKind kindType - in (dictTypeName <$> name, (k, TypeSynonym)) + in (dictTypeName . coerceProperName <$> name, (k, TypeSynonym)) ] -- | The primitive types in the external environment with their @@ -384,19 +366,19 @@ primTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypes = M.fromList - [ (primName "Type", (kindType, ExternData [])) - , (primName "Constraint", (kindType, ExternData [])) - , (primName "Symbol", (kindType, ExternData [])) - , (primName "Row", (kindType -:> kindType, ExternData [Phantom])) - , (primName "Function", (kindType -:> kindType -:> kindType, ExternData [Representational, Representational])) - , (primName "Array", (kindType -:> kindType, ExternData [Representational])) - , (primName "Record", (kindRow kindType -:> kindType, ExternData [Representational])) - , (primName "String", (kindType, ExternData [])) - , (primName "Char", (kindType, ExternData [])) - , (primName "Number", (kindType, ExternData [])) - , (primName "Int", (kindType, ExternData [])) - , (primName "Boolean", (kindType, ExternData [])) - , (primName "Partial", (kindConstraint, ExternData [])) + [ (C.Type, (kindType, ExternData [])) + , (C.Constraint, (kindType, ExternData [])) + , (C.Symbol, (kindType, ExternData [])) + , (C.Row, (kindType -:> kindType, ExternData [Phantom])) + , (C.Function, (kindType -:> kindType -:> kindType, ExternData [Representational, Representational])) + , (C.Array, (kindType -:> kindType, ExternData [Representational])) + , (C.Record, (kindRow kindType -:> kindType, ExternData [Representational])) + , (C.String, (kindType, ExternData [])) + , (C.Char, (kindType, ExternData [])) + , (C.Number, (kindType, ExternData [])) + , (C.Int, (kindType, ExternData [])) + , (C.Boolean, (kindType, ExternData [])) + , (C.Partial <&> coerceProperName, (kindConstraint, ExternData [])) ] -- | This 'Map' contains all of the prim types from all Prim modules. @@ -416,75 +398,75 @@ primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primBooleanTypes = M.fromList - [ (primSubName C.moduleBoolean "True", (tyBoolean, ExternData [])) - , (primSubName C.moduleBoolean "False", (tyBoolean, ExternData [])) + [ (C.True, (tyBoolean, ExternData [])) + , (C.False, (tyBoolean, ExternData [])) ] primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primCoerceTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleCoerce "Coercible") (\kind -> tyForall "k" kindType $ tyVar "k" -:> tyVar "k" -:> kind) + [ primClass C.Coercible (\kind -> tyForall "k" kindType $ tyVar "k" -:> tyVar "k" -:> kind) ] primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primOrderingTypes = M.fromList - [ (primSubName C.moduleOrdering "Ordering", (kindType, ExternData [])) - , (primSubName C.moduleOrdering "LT", (kindOrdering, ExternData [])) - , (primSubName C.moduleOrdering "EQ", (kindOrdering, ExternData [])) - , (primSubName C.moduleOrdering "GT", (kindOrdering, ExternData [])) + [ (C.TypeOrdering, (kindType, ExternData [])) + , (C.LT, (kindOrdering, ExternData [])) + , (C.EQ, (kindOrdering, ExternData [])) + , (C.GT, (kindOrdering, ExternData [])) ] primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleRow "Union") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) - , primClass (primSubName C.moduleRow "Nub") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) - , primClass (primSubName C.moduleRow "Lacks") (\kind -> tyForall "k" kindType $ kindSymbol -:> kindRow (tyVar "k") -:> kind) - , primClass (primSubName C.moduleRow "Cons") (\kind -> tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) + [ primClass C.RowUnion (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) + , primClass C.RowNub (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) + , primClass C.RowLacks (\kind -> tyForall "k" kindType $ kindSymbol -:> kindRow (tyVar "k") -:> kind) + , primClass C.RowCons (\kind -> tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) ] primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowListTypes = M.fromList $ - [ (primSubName C.moduleRowList "RowList", (kindType -:> kindType, ExternData [Phantom])) - , (primSubName C.moduleRowList "Cons", (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData [Phantom, Phantom, Phantom])) - , (primSubName C.moduleRowList "Nil", (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData [])) + [ (C.RowList, (kindType -:> kindType, ExternData [Phantom])) + , (C.RowListCons, (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData [Phantom, Phantom, Phantom])) + , (C.RowListNil, (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData [])) ] <> mconcat - [ primClass (primSubName C.moduleRowList "RowToList") (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRowList (tyVar "k") -:> kind) + [ primClass C.RowToList (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRowList (tyVar "k") -:> kind) ] primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primSymbolTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleSymbol "Append") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) - , primClass (primSubName C.moduleSymbol "Compare") (\kind -> kindSymbol -:> kindSymbol -:> kindOrdering -:> kind) - , primClass (primSubName C.moduleSymbol "Cons") (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) + [ primClass C.SymbolAppend (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) + , primClass C.SymbolCompare (\kind -> kindSymbol -:> kindSymbol -:> kindOrdering -:> kind) + , primClass C.SymbolCons (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) ] primIntTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primIntTypes = M.fromList $ mconcat - [ primClass (primSubName C.moduleInt "Add") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) - , primClass (primSubName C.moduleInt "Compare") (\kind -> tyInt -:> tyInt -:> kindOrdering -:> kind) - , primClass (primSubName C.moduleInt "Mul") (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) - , primClass (primSubName C.moduleInt "ToString") (\kind -> tyInt -:> kindSymbol -:> kind) + [ primClass C.IntAdd (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) + , primClass C.IntCompare (\kind -> tyInt -:> tyInt -:> kindOrdering -:> kind) + , primClass C.IntMul (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) + , primClass C.IntToString (\kind -> tyInt -:> kindSymbol -:> kind) ] primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypeErrorTypes = M.fromList $ - [ (primSubName C.typeError "Doc", (kindType, ExternData [])) - , (primSubName C.typeError "Fail", (kindDoc -:> kindConstraint, ExternData [Nominal])) - , (primSubName C.typeError "Warn", (kindDoc -:> kindConstraint, ExternData [Nominal])) - , (primSubName C.typeError "Text", (kindSymbol -:> kindDoc, ExternData [Phantom])) - , (primSubName C.typeError "Quote", (tyForall "k" kindType $ tyVar "k" -:> kindDoc, ExternData [Phantom])) - , (primSubName C.typeError "QuoteLabel", (kindSymbol -:> kindDoc, ExternData [Phantom])) - , (primSubName C.typeError "Beside", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) - , (primSubName C.typeError "Above", (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) + [ (C.Doc, (kindType, ExternData [])) + , (C.Fail <&> coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) + , (C.Warn <&> coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) + , (C.Text, (kindSymbol -:> kindDoc, ExternData [Phantom])) + , (C.Quote, (tyForall "k" kindType $ tyVar "k" -:> kindDoc, ExternData [Phantom])) + , (C.QuoteLabel, (kindSymbol -:> kindDoc, ExternData [Phantom])) + , (C.Beside, (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) + , (C.Above, (kindDoc -:> kindDoc -:> kindDoc, ExternData [Phantom, Phantom])) ] <> mconcat - [ primClass (primSubName C.typeError "Fail") (\kind -> kindDoc -:> kind) - , primClass (primSubName C.typeError "Warn") (\kind -> kindDoc -:> kind) + [ primClass C.Fail (\kind -> kindDoc -:> kind) + , primClass C.Warn (\kind -> kindDoc -:> kind) ] -- | The primitive class map. This just contains the `Partial` class. @@ -492,7 +474,7 @@ primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList - [ (primName "Partial", makeTypeClassData [] [] [] [] True) + [ (C.Partial, makeTypeClassData [] [] [] [] True) ] -- | This contains all of the type classes from all Prim modules. @@ -511,7 +493,7 @@ primCoerceClasses = M.fromList -- class Coercible (a :: k) (b :: k) - [ (primSubName C.moduleCoerce "Coercible", makeTypeClassData + [ (C.Coercible, makeTypeClassData [ ("a", Just (tyVar "k")) , ("b", Just (tyVar "k")) ] [] [] [] True) @@ -521,7 +503,7 @@ primRowClasses = M.fromList -- class Union (left :: Row k) (right :: Row k) (union :: Row k) | left right -> union, right union -> left, union left -> right - [ (primSubName C.moduleRow "Union", makeTypeClassData + [ (C.RowUnion, makeTypeClassData [ ("left", Just (kindRow (tyVar "k"))) , ("right", Just (kindRow (tyVar "k"))) , ("union", Just (kindRow (tyVar "k"))) @@ -532,7 +514,7 @@ ] True) -- class Nub (original :: Row k) (nubbed :: Row k) | original -> nubbed - , (primSubName C.moduleRow "Nub", makeTypeClassData + , (C.RowNub, makeTypeClassData [ ("original", Just (kindRow (tyVar "k"))) , ("nubbed", Just (kindRow (tyVar "k"))) ] [] [] @@ -540,13 +522,13 @@ ] True) -- class Lacks (label :: Symbol) (row :: Row k) - , (primSubName C.moduleRow "Lacks", makeTypeClassData + , (C.RowLacks, makeTypeClassData [ ("label", Just kindSymbol) , ("row", Just (kindRow (tyVar "k"))) ] [] [] [] True) -- class RowCons (label :: Symbol) (a :: k) (tail :: Row k) (row :: Row k) | label tail a -> row, label row -> tail a - , (primSubName C.moduleRow "Cons", makeTypeClassData + , (C.RowCons, makeTypeClassData [ ("label", Just kindSymbol) , ("a", Just (tyVar "k")) , ("tail", Just (kindRow (tyVar "k"))) @@ -561,7 +543,7 @@ primRowListClasses = M.fromList -- class RowToList (row :: Row k) (list :: RowList k) | row -> list - [ (primSubName C.moduleRowList "RowToList", makeTypeClassData + [ (C.RowToList, makeTypeClassData [ ("row", Just (kindRow (tyVar "k"))) , ("list", Just (kindRowList (tyVar "k"))) ] [] [] @@ -573,7 +555,7 @@ primSymbolClasses = M.fromList -- class Append (left :: Symbol) (right :: Symbol) (appended :: Symbol) | left right -> appended, right appended -> left, appended left -> right - [ (primSubName C.moduleSymbol "Append", makeTypeClassData + [ (C.SymbolAppend, makeTypeClassData [ ("left", Just kindSymbol) , ("right", Just kindSymbol) , ("appended", Just kindSymbol) @@ -584,7 +566,7 @@ ] True) -- class Compare (left :: Symbol) (right :: Symbol) (ordering :: Ordering) | left right -> ordering - , (primSubName C.moduleSymbol "Compare", makeTypeClassData + , (C.SymbolCompare, makeTypeClassData [ ("left", Just kindSymbol) , ("right", Just kindSymbol) , ("ordering", Just kindOrdering) @@ -593,7 +575,7 @@ ] True) -- class Cons (head :: Symbol) (tail :: Symbol) (symbol :: Symbol) | head tail -> symbol, symbol -> head tail - , (primSubName C.moduleSymbol "Cons", makeTypeClassData + , (C.SymbolCons, makeTypeClassData [ ("head", Just kindSymbol) , ("tail", Just kindSymbol) , ("symbol", Just kindSymbol) @@ -607,7 +589,7 @@ primIntClasses = M.fromList -- class Add (left :: Int) (right :: Int) (sum :: Int) | left right -> sum, left sum -> right, right sum -> left - [ (primSubName C.moduleInt "Add", makeTypeClassData + [ (C.IntAdd, makeTypeClassData [ ("left", Just tyInt) , ("right", Just tyInt) , ("sum", Just tyInt) @@ -618,7 +600,7 @@ ] True) -- class Compare (left :: Int) (right :: Int) (ordering :: Ordering) | left right -> ordering - , (primSubName C.moduleInt "Compare", makeTypeClassData + , (C.IntCompare, makeTypeClassData [ ("left", Just tyInt) , ("right", Just tyInt) , ("ordering", Just kindOrdering) @@ -627,7 +609,7 @@ ] True) -- class Mul (left :: Int) (right :: Int) (product :: Int) | left right -> product - , (primSubName C.moduleInt "Mul", makeTypeClassData + , (C.IntMul, makeTypeClassData [ ("left", Just tyInt) , ("right", Just tyInt) , ("product", Just tyInt) @@ -636,7 +618,7 @@ ] True) -- class ToString (int :: Int) (string :: Symbol) | int -> string - , (primSubName C.moduleInt "ToString", makeTypeClassData + , (C.IntToString, makeTypeClassData [ ("int", Just tyInt) , ("string", Just kindSymbol) ] [] [] @@ -648,11 +630,11 @@ primTypeErrorClasses = M.fromList -- class Fail (message :: Symbol) - [ (primSubName C.typeError "Fail", makeTypeClassData + [ (C.Fail, makeTypeClassData [("message", Just kindDoc)] [] [] [] True) -- class Warn (message :: Symbol) - , (primSubName C.typeError "Warn", makeTypeClassData + , (C.Warn, makeTypeClassData [("message", Just kindDoc)] [] [] [] True) ] diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -4,6 +4,7 @@ ) where import Prelude +import Protolude (unsnoc) import Control.Arrow ((&&&)) import Control.Exception (displayException) @@ -34,12 +35,11 @@ import qualified GHC.Stack import Language.PureScript.AST import qualified Language.PureScript.Bundle as Bundle -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import qualified Language.PureScript.Constants.Prim as C import Language.PureScript.Crash import qualified Language.PureScript.CST.Errors as CST import qualified Language.PureScript.CST.Print as CST -import Language.PureScript.Environment import Language.PureScript.Label (Label(..)) import Language.PureScript.Names import Language.PureScript.Pretty @@ -79,7 +79,7 @@ | OrphanKindDeclaration (ProperName 'TypeName) | OrphanRoleDeclaration (ProperName 'TypeName) | RedefinedIdent Ident - | OverlappingNamesInLet + | OverlappingNamesInLet Ident | UnknownName (Qualified Name) | UnknownImport ModuleName Name | UnknownImportDataConstructor ModuleName (ProperName 'TypeName) (ProperName 'ConstructorName) @@ -195,7 +195,7 @@ | UnsupportedRoleDeclaration | RoleDeclarationArityMismatch (ProperName 'TypeName) Int Int | DuplicateRoleDeclaration (ProperName 'TypeName) - | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) + | CannotDeriveInvalidConstructorArg (Qualified (ProperName 'ClassName)) [Qualified (ProperName 'ClassName)] Bool deriving (Show) data ErrorMessage = ErrorMessage @@ -258,7 +258,7 @@ OrphanKindDeclaration{} -> "OrphanKindDeclaration" OrphanRoleDeclaration{} -> "OrphanRoleDeclaration" RedefinedIdent{} -> "RedefinedIdent" - OverlappingNamesInLet -> "OverlappingNamesInLet" + OverlappingNamesInLet{} -> "OverlappingNamesInLet" UnknownName{} -> "UnknownName" UnknownImport{} -> "UnknownImport" UnknownImportDataConstructor{} -> "UnknownImportDataConstructor" @@ -588,6 +588,13 @@ , Box.vcat Box.top $ replicate (Box.rows b) $ Box.text ansiColorReset ] +commasAndConjunction :: Text -> [Text] -> Text +commasAndConjunction conj = \case + [x] -> x + [x, y] -> x <> " " <> conj <> " " <> y + (unsnoc -> Just (rest, z)) -> foldMap (<> ", ") rest <> conj <> " " <> z + _ -> "" + -- | Default color intensity and color for code defaultCodeColor :: (ANSI.ColorIntensity, ANSI.Color) defaultCodeColor = (ANSI.Dull, ANSI.Yellow) @@ -731,8 +738,8 @@ line "The last statement in a 'do' block must be an expression, but this block ends with a binder." renderSimpleErrorMessage InvalidDoLet = line "The last statement in a 'do' block must be an expression, but this block ends with a let binding." - renderSimpleErrorMessage OverlappingNamesInLet = - line "The same name was used more than once in a let binding." + renderSimpleErrorMessage (OverlappingNamesInLet name) = + line $ "The name " <> markCode (showIdent name) <> " was defined multiple times in a binding group" renderSimpleErrorMessage (InfiniteType ty) = paras [ line "An infinite type was inferred for an expression: " , markCodeBox $ indent $ prettyType ty @@ -753,10 +760,10 @@ line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" - renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.bind, C.discard ] = + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.S_bind, C.S_discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " and " <> markCode "discard" <> " functions. Please import " <> markCode i <> " from module " <> markCode "Prelude" - renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i == C.negate = - line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode i <> " function. Please import " <> markCode i <> " from module " <> markCode "Prelude" + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident C.S_negate)))) = + line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode C.S_negate <> " function. Please import " <> markCode C.S_negate <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = @@ -884,7 +891,7 @@ , line "because the class was not in scope. Perhaps it was not exported." ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Fail _ [ ty ] _) _ _) | Just box <- toTypelevelString ty = - paras [ line "A custom type error occurred while solving type class constraints:" + paras [ line "Custom error:" , indent box ] renderSimpleErrorMessage (NoInstanceFound (Constraint _ C.Partial @@ -1026,7 +1033,7 @@ renderSimpleErrorMessage (ExtraneousClassMember ident className) = line $ "" <> markCode (showIdent ident) <> " is not a member of type class " <> markCode (showQualified runProperName className) renderSimpleErrorMessage (ExpectedType ty kind) = - paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode C.typ <> "." + paras [ line $ "In a type-annotated expression " <> markCode "x :: t" <> ", the type " <> markCode "t" <> " must have kind " <> markCode (runProperName . disqualify $ C.Type) <> "." , line "The error arises from the type" , markCodeBox $ indent $ prettyType ty , line "having the kind" @@ -1379,11 +1386,12 @@ renderSimpleErrorMessage (DuplicateRoleDeclaration name) = line $ "Duplicate role declaration for " <> markCode (runProperName name) <> "." - renderSimpleErrorMessage (CannotDeriveInvalidConstructorArg className) = + renderSimpleErrorMessage (CannotDeriveInvalidConstructorArg className relatedClasses checkVariance) = paras [ line $ "One or more type variables are in positions that prevent " <> markCode (runProperName $ disqualify className) <> " from being derived." , line $ "To derive this class, make sure that these variables are only used as the final arguments to type constructors, " - <> "and that those type constructors themselves have instances of " <> markCode (runProperName $ disqualify className) <> "." + <> (if checkVariance then "that their variance matches the variance of " <> markCode (runProperName $ disqualify className) <> ", " else "") + <> "and that those type constructors themselves have instances of " <> commasAndConjunction "or" (markCode . showQualified runProperName <$> relatedClasses) <> "." ] renderHint :: ErrorMessageHint -> Box.Box -> Box.Box @@ -1941,18 +1949,16 @@ toTypelevelString :: Type a -> Maybe Box.Box toTypelevelString (TypeLevelString _ s) = Just . Box.text $ decodeStringWithReplacement s -toTypelevelString (TypeApp _ (TypeConstructor _ f) x) - | f == primSubName C.typeError "Text" = toTypelevelString x -toTypelevelString (TypeApp _ (KindApp _ (TypeConstructor _ f) _) x) - | f == primSubName C.typeError "Quote" = Just (typeAsBox maxBound x) -toTypelevelString (TypeApp _ (TypeConstructor _ f) (TypeLevelString _ x)) - | f == primSubName C.typeError "QuoteLabel" = Just . line . prettyPrintLabel . Label $ x -toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) - | f == primSubName C.typeError "Beside" = - (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret -toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ f) x) ret) - | f == primSubName C.typeError "Above" = - (Box.//) <$> toTypelevelString x <*> toTypelevelString ret +toTypelevelString (TypeApp _ (TypeConstructor _ C.Text) x) = + toTypelevelString x +toTypelevelString (TypeApp _ (KindApp _ (TypeConstructor _ C.Quote) _) x) = + Just (typeAsBox maxBound x) +toTypelevelString (TypeApp _ (TypeConstructor _ C.QuoteLabel) (TypeLevelString _ x)) = + Just . line . prettyPrintLabel . Label $ x +toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ C.Beside) x) ret) = + (Box.<>) <$> toTypelevelString x <*> toTypelevelString ret +toTypelevelString (TypeApp _ (TypeApp _ (TypeConstructor _ C.Above) x) ret) = + (Box.//) <$> toTypelevelString x <*> toTypelevelString ret toTypelevelString _ = Nothing -- | Rethrow an error with a more detailed error message in the case of failure diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -30,7 +30,8 @@ import Language.PureScript.Ide.Error import Language.PureScript.Ide.Externs import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.Imports hiding (Import) +import Language.PureScript.Ide.Imports hiding (Import) +import Language.PureScript.Ide.Imports.Actions import Language.PureScript.Ide.Matcher import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Rebuild diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -91,8 +91,8 @@ prettyCtor :: WildcardAnnotations -> Constructor -> Text prettyCtor _ (ctorName, []) = P.runProperName ctorName prettyCtor wsa (ctorName, ctorArgs) = - "("<> P.runProperName ctorName <> " " - <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <>")" + "(" <> P.runProperName ctorName <> " " + <> T.unwords (map (prettyPrintWildcard wsa) ctorArgs) <> ")" prettyPrintWildcard :: WildcardAnnotations -> P.Type a -> Text prettyPrintWildcard (WildcardAnnotations True) = prettyWildcard diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -89,7 +89,7 @@ where go (Match (moduleName, d@(IdeDeclarationAnn ann decl))) = let - origin = fromMaybe moduleName (ann^.annExportedFrom) + origin = fromMaybe moduleName (ann ^. annExportedFrom) in Map.alter (insertDeclaration moduleName origin d) diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -90,7 +90,7 @@ textError (GeneralError msg) = msg textError (NotFound ident) = "Symbol '" <> ident <> "' not found." textError (ModuleNotFound ident) = "Module '" <> ident <> "' not found." -textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <>" could not be found" +textError (ModuleFileNotFound ident) = "Extern file for module " <> ident <> " could not be found" textError (RebuildError _ err) = show err prettyPrintTypeSingleLine :: P.Type a -> Text diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -69,14 +69,14 @@ Nothing -> acc Just tyDecl -> IdeDeclTypeClass - (IdeTypeClass tcn (tyDecl^.ideTypeKind) []) + (IdeTypeClass tcn (tyDecl ^. ideTypeKind) []) : filter (not . anyOf (_IdeDeclType . ideTypeName) (== P.coerceProperName tcn)) acc SynonymToResolve tn ty -> case findType tn acc of Nothing -> acc Just tyDecl -> - IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl^.ideTypeKind)) + IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl ^. ideTypeKind)) : filter (not . anyOf (_IdeDeclType . ideTypeName) (== tn)) acc findType :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeType @@ -103,14 +103,14 @@ -- because those are typechecker internal definitions that shouldn't -- be user facing P.EDType{..} -> Right do - guard (isNothing (Text.find (== '$') (edTypeName^.properNameT))) + guard (isNothing (Text.find (== '$') (edTypeName ^. properNameT))) Just (IdeDeclType (IdeType edTypeName edTypeKind [])) P.EDTypeSynonym{..} -> - if isNothing (Text.find (== '$') (edTypeSynonymName^.properNameT)) + if isNothing (Text.find (== '$') (edTypeSynonymName ^. properNameT)) then Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) else Right Nothing P.EDDataConstructor{..} -> Right do - guard (isNothing (Text.find (== '$') (edDataCtorName^.properNameT))) + guard (isNothing (Text.find (== '$') (edDataCtorName ^. properNameT))) Just (IdeDeclDataConstructor (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType)) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -19,6 +19,7 @@ , exactFilter , prefixFilter , declarationTypeFilter + , dependencyFilter , applyFilters ) where @@ -31,9 +32,14 @@ import qualified Data.Map as Map import Language.PureScript.Ide.Filter.Declaration (DeclarationType) import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Imports import Language.PureScript.Ide.Util + import qualified Language.PureScript as P +import qualified Data.Text as T +import Language.PureScript.Ide.Filter.Imports + newtype Filter = Filter (Either (Set P.ModuleName) DeclarationFilter) deriving Show @@ -45,6 +51,7 @@ | Exact Text | Namespace (Set IdeNamespace) | DeclType (Set DeclarationType) + | Dependencies { qualifier :: Maybe P.ModuleName, currentModuleName :: P.ModuleName, dependencyImports :: [Import] } deriving Show -- | Only keeps Declarations in the given modules @@ -67,6 +74,9 @@ declarationTypeFilter :: Set DeclarationType -> Filter declarationTypeFilter dts = Filter (Right (DeclType dts)) +dependencyFilter :: Maybe P.ModuleName -> P.ModuleName -> [Import] -> Filter +dependencyFilter q m f = Filter (Right (Dependencies q m f)) + optimizeFilters :: [Filter] -> (Maybe (Set P.ModuleName), [DeclarationFilter]) optimizeFilters = first smashModuleFilters . partitionEithers . map unFilter where @@ -88,17 +98,19 @@ -> ModuleMap [IdeDeclarationAnn] applyDeclarationFilters fs = Map.filter (not . null) - . Map.map (foldr (.) identity (map applyDeclarationFilter fs)) + . Map.mapWithKey (\modl decls -> foldr (.) identity (map (applyDeclarationFilter modl) fs) decls) applyDeclarationFilter - :: DeclarationFilter + :: P.ModuleName + -> DeclarationFilter -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] -applyDeclarationFilter f = case f of +applyDeclarationFilter modl f = case f of Prefix prefix -> prefixFilter' prefix Exact t -> exactFilter' t Namespace namespaces -> namespaceFilter' namespaces DeclType dts -> declarationTypeFilter' dts + Dependencies qual currentModuleName imps -> dependencyFilter' modl qual currentModuleName imps namespaceFilter' :: Set IdeNamespace -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] namespaceFilter' namespaces = @@ -116,6 +128,13 @@ declarationTypeFilter' declTypes = filter (\decl -> declarationType (discardAnn decl) `Set.member` declTypes) +dependencyFilter' :: P.ModuleName -> Maybe P.ModuleName -> P.ModuleName -> [Import] -> [IdeDeclarationAnn] -> [IdeDeclarationAnn] +dependencyFilter' modl qual currentModuleName imports = + if modl == currentModuleName && isNothing qual then + identity + else + filter (\decl -> any (matchImport qual modl decl) imports) + instance FromJSON Filter where parseJSON = withObject "filter" $ \o -> do (filter' :: Text) <- o .: "filter" @@ -129,7 +148,7 @@ search <- params .: "search" pure (exactFilter search) "prefix" -> do - params <- o.: "params" + params <- o .: "params" search <- params .: "search" pure (prefixFilter search) "namespace" -> do @@ -137,6 +156,13 @@ namespaces <- params .: "namespaces" pure (namespaceFilter (Set.fromList namespaces)) "declarations" -> do - declarations <- o.: "params" + declarations <- o .: "params" pure (declarationTypeFilter (Set.fromList declarations)) + "dependencies" -> do + params <- o .: "params" + moduleText <- params .: "moduleText" + qualifier <- fmap P.moduleNameFromString <$> params .:? "qualifier" + case sliceImportSection (T.lines moduleText) of + Left err -> fail ("Couldn't parse module imports: " <> T.unpack err) + Right (currentModuleName, _, imports, _ ) -> pure (dependencyFilter qualifier currentModuleName imports) s -> fail ("Unknown filter: " <> show s) diff --git a/src/Language/PureScript/Ide/Filter/Imports.hs b/src/Language/PureScript/Ide/Filter/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Ide/Filter/Imports.hs @@ -0,0 +1,31 @@ +module Language.PureScript.Ide.Filter.Imports where + + +import Protolude hiding (isPrefixOf) + +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Imports + +import qualified Language.PureScript as P + +matchImport :: Maybe P.ModuleName -> P.ModuleName -> IdeDeclarationAnn -> Import -> Bool +matchImport matchQualifier declMod (IdeDeclarationAnn _ decl) (Import importMod declTy qualifier) | declMod == importMod && matchQualifier == qualifier = + case declTy of + P.Implicit -> True + P.Explicit refs -> any (matchRef decl) refs + P.Hiding refs -> not $ any (matchRef decl) refs + where + matchRef (IdeDeclValue (IdeValue ident _)) (P.ValueRef _ ident') = ident == ident' + matchRef (IdeDeclType (IdeType tname _kind _dctors)) (P.TypeRef _ tname' _dctors') = tname == tname' + matchRef (IdeDeclTypeSynonym (IdeTypeSynonym tname _type _kind)) (P.TypeRef _ tname' _dctors) = tname == tname' -- Can this occur? + + matchRef (IdeDeclDataConstructor (IdeDataConstructor dcname tname _type)) (P.TypeRef _ tname' dctors) = + tname == tname' + && maybe True (dcname `elem`) dctors -- (..) or explicitly lists constructor + + matchRef (IdeDeclTypeClass (IdeTypeClass tcname _kind _instances)) (P.TypeClassRef _ tcname') = tcname == tcname' + matchRef (IdeDeclValueOperator (IdeValueOperator{ _ideValueOpName })) (P.ValueOpRef _ opname) = _ideValueOpName == opname + matchRef (IdeDeclTypeOperator (IdeTypeOperator{ _ideTypeOpName })) (P.TypeOpRef _ opname) = _ideTypeOpName == opname + matchRef _ _ = False + +matchImport _ _ _ _ = False diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -13,17 +13,11 @@ ----------------------------------------------------------------------------- module Language.PureScript.Ide.Imports - ( addImplicitImport - , addQualifiedImport - , addImportForIdentifier - , answerRequest - , parseImportsFromFile + ( parseImportsFromFile + , parseImportsFromFile' -- for tests , parseImport , prettyPrintImportSection - , addImplicitImport' - , addQualifiedImport' - , addExplicitImport' , sliceImportSection , prettyPrintImport' , Import(Import) @@ -32,22 +26,14 @@ import Protolude hiding (moduleName) -import Control.Lens ((^.), (%~), ix, has) -import Data.List (nubBy, partition) +import Control.Lens ((^.), (%~), ix) +import Data.List (partition) import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map import qualified Data.Text as T import qualified Language.PureScript as P -import qualified Language.PureScript.Constants.Prim as C import qualified Language.PureScript.CST as CST -import Language.PureScript.Ide.Completion import Language.PureScript.Ide.Error -import Language.PureScript.Ide.Filter -import Language.PureScript.Ide.State -import Language.PureScript.Ide.Prim -import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util -import System.IO.UTF8 (writeUTF8FileT) data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName) deriving (Eq, Show) @@ -136,201 +122,6 @@ & ix 0 %~ T.drop (c1 - 1) & ix (l2 - l1) %~ T.take c2 --- | Adds an implicit import like @import Prelude@ to a Sourcefile. -addImplicitImport - :: (MonadIO m, MonadError IdeError m) - => FilePath -- ^ The source file read from - -> P.ModuleName -- ^ The module to import - -> m [Text] -addImplicitImport fp mn = do - (_, pre, imports, post) <- parseImportsFromFile' fp - let newImportSection = addImplicitImport' imports mn - pure $ joinSections (pre, newImportSection, post) - -addImplicitImport' :: [Import] -> P.ModuleName -> [Text] -addImplicitImport' imports mn = - prettyPrintImportSection (Import mn P.Implicit Nothing : imports) - --- | Adds a qualified import like @import Data.Map as Map@ to a source file. -addQualifiedImport - :: (MonadIO m, MonadError IdeError m) - => FilePath - -- ^ The sourcefile read from - -> P.ModuleName - -- ^ The module to import - -> P.ModuleName - -- ^ The qualifier under which to import - -> m [Text] -addQualifiedImport fp mn qualifier = do - (_, pre, imports, post) <- parseImportsFromFile' fp - let newImportSection = addQualifiedImport' imports mn qualifier - pure $ joinSections (pre, newImportSection, post) - -addQualifiedImport' :: [Import] -> P.ModuleName -> P.ModuleName -> [Text] -addQualifiedImport' imports mn qualifier = - prettyPrintImportSection (Import mn P.Implicit (Just qualifier) : imports) - --- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an --- explicit import already exists for the given module, it adds the identifier --- to that imports list. --- --- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing --- @import Prelude (bind)@ in the file File.purs returns @["import Prelude --- (bind, unit)"]@ -addExplicitImport :: (MonadIO m, MonadError IdeError m) => - FilePath -> IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> m [Text] -addExplicitImport fp decl moduleName qualifier = do - (mn, pre, imports, post) <- parseImportsFromFile' fp - let newImportSection = - -- TODO: Open an issue when this PR is merged, we should optimise this - -- so that this case does not write to disc - if mn == moduleName - then imports - else addExplicitImport' decl moduleName qualifier imports - pure $ joinSections (pre, prettyPrintImportSection newImportSection, post) - -addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [Import] -> [Import] -addExplicitImport' decl moduleName qualifier imports = - let - isImplicitlyImported = - any (\case - Import mn P.Implicit qualifier' -> mn == moduleName && qualifier == qualifier' - _ -> False) imports - isNotExplicitlyImportedFromPrim = - moduleName == C.Prim && - not (any (\case - Import C.Prim (P.Explicit _) Nothing -> True - _ -> False) imports) - -- We can't import Modules from other modules - isModule = has _IdeDeclModule decl - - matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier' - matches _ = False - freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier - in - if isImplicitlyImported || isNotExplicitlyImportedFromPrim || isModule - then imports - else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports - where - refFromDeclaration (IdeDeclTypeClass tc) = - P.TypeClassRef ideSpan (tc ^. ideTCName) - refFromDeclaration (IdeDeclDataConstructor dtor) = - P.TypeRef ideSpan (dtor ^. ideDtorTypeName) Nothing - refFromDeclaration (IdeDeclType t) = - P.TypeRef ideSpan (t ^. ideTypeName) (Just []) - refFromDeclaration (IdeDeclValueOperator op) = - P.ValueOpRef ideSpan (op ^. ideValueOpName) - refFromDeclaration (IdeDeclTypeOperator op) = - P.TypeOpRef ideSpan (op ^. ideTypeOpName) - refFromDeclaration d = - P.ValueRef ideSpan (P.Ident (identifierFromIdeDeclaration d)) - - -- | Adds a declaration to an import: - -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) - insertDeclIntoImport :: IdeDeclaration -> Import -> Import - insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) = - Import mn (P.Explicit (sort (insertDeclIntoRefs decl' refs))) qual - insertDeclIntoImport _ is = is - - insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] - insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs = - updateAtFirstOrPrepend - (matchType (dtor ^. ideDtorTypeName)) - (insertDtor (dtor ^. ideDtorName)) - (refFromDeclaration d) - refs - insertDeclIntoRefs (IdeDeclType t) refs - | any matches refs = refs - where - matches (P.TypeRef _ typeName _) = _ideTypeName t == typeName - matches _ = False - insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) - - insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing - insertDtor _ refs = refs - - matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool - matchType tn (P.TypeRef _ n _) = tn == n - matchType _ _ = False - -ideSpan :: P.SourceSpan -ideSpan = P.internalModuleSourceSpan "" - --- | If none of the elements of the list satisfy the given predicate 'predicate', then prepend the default value 'def' --- to the given list. Otherwise, update the first element of the list that satisfies 'predicate' with the updating --- function 'update'. -updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] -updateAtFirstOrPrepend predicate update def xs = - case break predicate xs of - (before, []) -> def : before - (before, x : after) -> before ++ [update x] ++ after - --- | Looks up the given identifier in the currently loaded modules. --- --- * Throws an error if the identifier cannot be found. --- --- * If exactly one match is found, adds an explicit import to the importsection --- --- * If more than one possible imports are found, reports the possibilities as a --- list of completions. -addImportForIdentifier - :: (Ide m, MonadError IdeError m) - => FilePath -- ^ The Sourcefile to read from - -> Text -- ^ The identifier to import - -> Maybe P.ModuleName -- ^ The optional qualifier under which to import - -> [Filter] -- ^ Filters to apply before searching for the identifier - -> m (Either [Match IdeDeclaration] [Text]) -addImportForIdentifier fp ident qual filters = do - let addPrim = Map.union idePrimDeclarations - modules <- getAllModules Nothing - let - matches = - getExactMatches ident filters (addPrim modules) - & map (fmap discardAnn) - & filter (\(Match (_, d)) -> not (has _IdeDeclModule d)) - - case matches of - [] -> - throwError (NotFound "Couldn't find the given identifier. \ - \Have you loaded the corresponding module?") - - -- Only one match was found for the given identifier, so we can insert it - -- right away - [Match (m, decl)] -> - Right <$> addExplicitImport fp decl m qual - - -- This case comes up for newtypes and dataconstructors. Because values and - -- types don't share a namespace we can get multiple matches from the same - -- module. This also happens for parameterized types, as these generate both - -- a type as well as a type synonym. - - ms@[Match (m1, d1), Match (m2, d2)] -> - if m1 /= m2 - -- If the modules don't line up we just ask the user to specify the - -- module - then pure (Left ms) - else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of - -- If dataconstructor and type line up we just import the - -- dataconstructor as that will give us an unnecessary import warning at - -- worst - Just decl -> - Right <$> addExplicitImport fp decl m1 qual - -- Here we need the user to specify whether they wanted a - -- dataconstructor or a type - Nothing -> - throwError (GeneralError "Undecidable between type and dataconstructor") - - -- Multiple matches were found so we need to ask the user to clarify which - -- module they meant - xs -> - pure (Left xs) - where - decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) = - if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing - decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} = - Just ts - decideRedundantCase _ _ = Nothing - prettyPrintImport' :: Import -> Text prettyPrintImport' (Import mn idt qual) = "import " <> P.prettyPrintImport mn idt qual @@ -352,18 +143,6 @@ Import _ (P.Hiding _) Nothing -> True _ -> False - --- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@, --- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the --- first argument. -answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success -answerRequest outfp rs = - case outfp of - Nothing -> pure (MultilineTextResult rs) - Just outfp' -> do - liftIO (writeUTF8FileT outfp' (T.unlines rs)) - pure (TextResult ("Written to " <> T.pack outfp')) - -- | Test and ghci helper parseImport :: Text -> Maybe Import parseImport t = @@ -373,15 +152,3 @@ Right (_, mn, idt, mmn) -> Just (Import mn idt mmn) _ -> Nothing - -joinSections :: ([Text], [Text], [Text]) -> [Text] -joinSections (pre, decls, post) = pre `joinLine` (decls `joinLine` post) - where - isBlank = T.all (== ' ') - joinLine as bs - | Just ln1 <- lastMay as - , Just ln2 <- head bs - , not (isBlank ln1) && not (isBlank ln2) = - as ++ [""] ++ bs - | otherwise = - as ++ bs diff --git a/src/Language/PureScript/Ide/Imports/Actions.hs b/src/Language/PureScript/Ide/Imports/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Ide/Imports/Actions.hs @@ -0,0 +1,251 @@ +module Language.PureScript.Ide.Imports.Actions + ( addImplicitImport + , addQualifiedImport + , addImportForIdentifier + , answerRequest + + -- for tests + , addImplicitImport' + , addQualifiedImport' + , addExplicitImport' + ) +where + +import Protolude hiding (moduleName) + +import Control.Lens ((^.), has) +import Data.List (nubBy) +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Language.PureScript as P +import qualified Language.PureScript.Constants.Prim as C +import Language.PureScript.Ide.Completion +import Language.PureScript.Ide.Error +import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.State +import Language.PureScript.Ide.Prim +import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Util +import System.IO.UTF8 (writeUTF8FileT) + +-- | Adds an implicit import like @import Prelude@ to a Sourcefile. +addImplicitImport + :: (MonadIO m, MonadError IdeError m) + => FilePath -- ^ The source file read from + -> P.ModuleName -- ^ The module to import + -> m [Text] +addImplicitImport fp mn = do + (_, pre, imports, post) <- parseImportsFromFile' fp + let newImportSection = addImplicitImport' imports mn + pure $ joinSections (pre, newImportSection, post) + +addImplicitImport' :: [Import] -> P.ModuleName -> [Text] +addImplicitImport' imports mn = + prettyPrintImportSection (Import mn P.Implicit Nothing : imports) + +-- | Adds a qualified import like @import Data.Map as Map@ to a source file. +addQualifiedImport + :: (MonadIO m, MonadError IdeError m) + => FilePath + -- ^ The sourcefile read from + -> P.ModuleName + -- ^ The module to import + -> P.ModuleName + -- ^ The qualifier under which to import + -> m [Text] +addQualifiedImport fp mn qualifier = do + (_, pre, imports, post) <- parseImportsFromFile' fp + let newImportSection = addQualifiedImport' imports mn qualifier + pure $ joinSections (pre, newImportSection, post) + +addQualifiedImport' :: [Import] -> P.ModuleName -> P.ModuleName -> [Text] +addQualifiedImport' imports mn qualifier = + prettyPrintImportSection (Import mn P.Implicit (Just qualifier) : imports) + +-- | Adds an explicit import like @import Prelude (unit)@ to a Sourcefile. If an +-- explicit import already exists for the given module, it adds the identifier +-- to that imports list. +-- +-- So @addExplicitImport "/File.purs" "bind" "Prelude"@ with an already existing +-- @import Prelude (bind)@ in the file File.purs returns @["import Prelude +-- (bind, unit)"]@ +addExplicitImport :: (MonadIO m, MonadError IdeError m) => + FilePath -> IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> m [Text] +addExplicitImport fp decl moduleName qualifier = do + (mn, pre, imports, post) <- parseImportsFromFile' fp + let newImportSection = + -- TODO: Open an issue when this PR is merged, we should optimise this + -- so that this case does not write to disc + if mn == moduleName + then imports + else addExplicitImport' decl moduleName qualifier imports + pure $ joinSections (pre, prettyPrintImportSection newImportSection, post) + +addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [Import] -> [Import] +addExplicitImport' decl moduleName qualifier imports = + let + isImplicitlyImported = + any (\case + Import mn P.Implicit qualifier' -> mn == moduleName && qualifier == qualifier' + _ -> False) imports + isNotExplicitlyImportedFromPrim = + moduleName == C.M_Prim && + not (any (\case + Import C.M_Prim (P.Explicit _) Nothing -> True + _ -> False) imports) + -- We can't import Modules from other modules + isModule = has _IdeDeclModule decl + + matches (Import mn (P.Explicit _) qualifier') = mn == moduleName && qualifier == qualifier' + matches _ = False + freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) qualifier + in + if isImplicitlyImported || isNotExplicitlyImportedFromPrim || isModule + then imports + else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports + where + refFromDeclaration (IdeDeclTypeClass tc) = + P.TypeClassRef ideSpan (tc ^. ideTCName) + refFromDeclaration (IdeDeclDataConstructor dtor) = + P.TypeRef ideSpan (dtor ^. ideDtorTypeName) Nothing + refFromDeclaration (IdeDeclType t) = + P.TypeRef ideSpan (t ^. ideTypeName) (Just []) + refFromDeclaration (IdeDeclValueOperator op) = + P.ValueOpRef ideSpan (op ^. ideValueOpName) + refFromDeclaration (IdeDeclTypeOperator op) = + P.TypeOpRef ideSpan (op ^. ideTypeOpName) + refFromDeclaration d = + P.ValueRef ideSpan (P.Ident (identifierFromIdeDeclaration d)) + + -- | Adds a declaration to an import: + -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) + insertDeclIntoImport :: IdeDeclaration -> Import -> Import + insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) = + Import mn (P.Explicit (sort (insertDeclIntoRefs decl' refs))) qual + insertDeclIntoImport _ is = is + + insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] + insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs = + updateAtFirstOrPrepend + (matchType (dtor ^. ideDtorTypeName)) + (insertDtor (dtor ^. ideDtorName)) + (refFromDeclaration d) + refs + insertDeclIntoRefs (IdeDeclType t) refs + | any matches refs = refs + where + matches (P.TypeRef _ typeName _) = _ideTypeName t == typeName + matches _ = False + insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) + + insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing + insertDtor _ refs = refs + + matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool + matchType tn (P.TypeRef _ n _) = tn == n + matchType _ _ = False + + +-- | Looks up the given identifier in the currently loaded modules. +-- +-- * Throws an error if the identifier cannot be found. +-- +-- * If exactly one match is found, adds an explicit import to the importsection +-- +-- * If more than one possible imports are found, reports the possibilities as a +-- list of completions. +addImportForIdentifier + :: (Ide m, MonadError IdeError m) + => FilePath -- ^ The Sourcefile to read from + -> Text -- ^ The identifier to import + -> Maybe P.ModuleName -- ^ The optional qualifier under which to import + -> [Filter] -- ^ Filters to apply before searching for the identifier + -> m (Either [Match IdeDeclaration] [Text]) +addImportForIdentifier fp ident qual filters = do + let addPrim = Map.union idePrimDeclarations + modules <- getAllModules Nothing + let + matches = + getExactMatches ident filters (addPrim modules) + & map (fmap discardAnn) + & filter (\(Match (_, d)) -> not (has _IdeDeclModule d)) + + case matches of + [] -> + throwError (NotFound "Couldn't find the given identifier. \ + \Have you loaded the corresponding module?") + + -- Only one match was found for the given identifier, so we can insert it + -- right away + [Match (m, decl)] -> + Right <$> addExplicitImport fp decl m qual + + -- This case comes up for newtypes and dataconstructors. Because values and + -- types don't share a namespace we can get multiple matches from the same + -- module. This also happens for parameterized types, as these generate both + -- a type as well as a type synonym. + + ms@[Match (m1, d1), Match (m2, d2)] -> + if m1 /= m2 + -- If the modules don't line up we just ask the user to specify the + -- module + then pure (Left ms) + else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of + -- If dataconstructor and type line up we just import the + -- dataconstructor as that will give us an unnecessary import warning at + -- worst + Just decl -> + Right <$> addExplicitImport fp decl m1 qual + -- Here we need the user to specify whether they wanted a + -- dataconstructor or a type + Nothing -> + throwError (GeneralError "Undecidable between type and dataconstructor") + + -- Multiple matches were found so we need to ask the user to clarify which + -- module they meant + xs -> + pure (Left xs) + where + decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) = + if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing + decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} = + Just ts + decideRedundantCase _ _ = Nothing + +-- | Writes a list of lines to @Just filepath@ and responds with a @TextResult@, +-- or returns the lines as a @MultilineTextResult@ if @Nothing@ was given as the +-- first argument. +answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success +answerRequest outfp rs = + case outfp of + Nothing -> pure (MultilineTextResult rs) + Just outfp' -> do + liftIO (writeUTF8FileT outfp' (T.unlines rs)) + pure (TextResult ("Written to " <> T.pack outfp')) + + +-- | If none of the elements of the list satisfy the given predicate 'predicate', then prepend the default value 'def' +-- to the given list. Otherwise, update the first element of the list that satisfies 'predicate' with the updating +-- function 'update'. +updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] +updateAtFirstOrPrepend predicate update def xs = + case break predicate xs of + (before, []) -> def : before + (before, x : after) -> before ++ [update x] ++ after + + +ideSpan :: P.SourceSpan +ideSpan = P.internalModuleSourceSpan "" + +joinSections :: ([Text], [Text], [Text]) -> [Text] +joinSections (pre, decls, post) = pre `joinLine` (decls `joinLine` post) + where + isBlank = T.all (== ' ') + joinLine as bs + | Just ln1 <- lastMay as + , Just ln2 <- head bs + , not (isBlank ln1) && not (isBlank ln2) = + as ++ [""] ++ bs + | otherwise = + as ++ bs diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs --- a/src/Language/PureScript/Ide/Matcher.hs +++ b/src/Language/PureScript/Ide/Matcher.hs @@ -94,7 +94,7 @@ -- Borrowed from: http://cdewaka.com/2013/06/fuzzy-pattern-matching-in-haskell/ -- -- By string =~ pattern we'll get the start of the match and the length of --- the matchas a (start, length) tuple if there's a match. +-- the matches a (start, length) tuple if there's a match. -- If match fails then it would be (-1,0) flexScore :: Text -> Text -> Maybe Double flexScore pat str = diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -11,28 +11,28 @@ idePrimDeclarations :: ModuleMap [IdeDeclarationAnn] idePrimDeclarations = Map.fromList - [ ( C.Prim + [ ( C.M_Prim , mconcat [primTypes, primClasses] ) - , ( C.PrimBoolean + , ( C.M_Prim_Boolean , mconcat [primBooleanTypes] ) - , ( C.PrimOrdering + , ( C.M_Prim_Ordering , mconcat [primOrderingTypes] ) - , ( C.PrimRow + , ( C.M_Prim_Row , mconcat [primRowTypes, primRowClasses] ) - , ( C.PrimRowList + , ( C.M_Prim_RowList , mconcat [primRowListTypes, primRowListClasses] ) - , ( C.PrimSymbol + , ( C.M_Prim_Symbol , mconcat [primSymbolTypes, primSymbolClasses] ) - , ( C.PrimInt + , ( C.M_Prim_Int , mconcat [primIntTypes, primIntClasses] ) - , ( C.PrimTypeError + , ( C.M_Prim_TypeError , mconcat [primTypeErrorTypes, primTypeErrorClasses] ) ] diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -14,9 +14,12 @@ import Data.Maybe (fromJust) import qualified Data.Set as S import qualified Data.Time as Time +import qualified Data.Text as Text import qualified Language.PureScript as P +import Language.PureScript.Make (ffiCodegen') import Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache) import qualified Language.PureScript.CST as CST + import Language.PureScript.Ide.Error import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State @@ -51,7 +54,10 @@ -- ^ A runner for the second build with open exports -> m Success rebuildFile file actualFile codegenTargets runOpenBuild = do - (fp, input) <- ideReadFile file + (fp, input) <- + case List.stripPrefix "data:" file of + Just source -> pure ("", Text.pack source) + _ -> ideReadFile file let fp' = fromMaybe fp actualFile (pwarnings, m) <- case sequence $ CST.parseFromFile fp' input of Left parseError -> @@ -65,13 +71,18 @@ -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign -- modules using their file paths, we need to specify the path in the 'Map'. let filePathMap = M.singleton moduleName (Left P.RebuildAlways) - foreigns <- P.inferForeignModules (M.singleton moduleName (Right file)) + let pureRebuild = fp == "" + let modulePath = if pureRebuild then fp' else file + foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath)) let makeEnv = P.buildMakeActions outputDirectory filePathMap foreigns False + & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity) + & shushProgress -- Rebuild the single module using the cached externs (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $ liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) do - newExterns <- P.rebuildModule (shushProgress makeEnv) externs m - updateCacheDb codegenTargets outputDirectory file actualFile moduleName + newExterns <- P.rebuildModule makeEnv externs m + unless pureRebuild + $ updateCacheDb codegenTargets outputDirectory file actualFile moduleName pure newExterns case result of Left errors -> @@ -174,6 +185,16 @@ shushCodegen ma = ma { P.codegen = \_ _ _ -> pure () , P.ffiCodegen = \_ -> pure () + } + +-- | Enables foreign module check without actual codegen. +enableForeignCheck + :: M.Map P.ModuleName FilePath + -> S.Set P.CodegenTarget + -> P.MakeActions P.Make + -> P.MakeActions P.Make +enableForeignCheck foreigns codegenTargets ma = + ma { P.ffiCodegen = ffiCodegen' foreigns codegenTargets Nothing } -- | Returns a topologically sorted list of dependent ExternsFiles for the given diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -207,7 +207,7 @@ (\mn -> logWarnN . prettyPrintReexportResult (const (P.runModuleName mn))) (Map.filter reexportHasFailures results) -populateVolatileState :: (Ide m, MonadLogger m) => m (Async ()) +populateVolatileState :: Ide m => m (Async ()) populateVolatileState = do env <- ask let ll = confLogLevel (ideConfiguration env) diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -25,7 +25,7 @@ -- module. -- 3. Apply the collected search specifications and collect the results findUsages - :: (MonadIO m, Ide m) + :: Ide m => IdeDeclaration -> P.ModuleName -> m (ModuleMap (NonEmpty P.SourceSpan)) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -178,7 +178,7 @@ -- | Show actual loaded modules in psci. handleShowLoadedModules - :: (MonadState PSCiState m, MonadIO m) + :: MonadState PSCiState m => (String -> m ()) -> m () handleShowLoadedModules print' = do @@ -189,7 +189,7 @@ -- | Show the imported modules in psci. handleShowImportedModules - :: (MonadState PSCiState m, MonadIO m) + :: MonadState PSCiState m => (String -> m ()) -> m () handleShowImportedModules print' = do @@ -230,7 +230,7 @@ commaList = T.intercalate ", " handleShowPrint - :: (MonadState PSCiState m, MonadIO m) + :: MonadState PSCiState m => (String -> m ()) -> m () handleShowPrint print' = do @@ -305,7 +305,7 @@ -- | Browse a module and displays its signature handleBrowse - :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m) + :: (MonadReader PSCiConfig m, MonadState PSCiState m) => (String -> m ()) -> P.ModuleName -> m () diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -19,7 +19,7 @@ import Language.PureScript.Linter.Imports as L import Language.PureScript.Names import Language.PureScript.Types -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | Lint the PureScript AST. -- | @@ -162,7 +162,7 @@ thisModuleRef _ = False rebindable :: S.Set Ident - rebindable = S.fromList [ Ident C.bind, Ident C.discard ] + rebindable = S.fromList [ Ident C.S_bind, Ident C.S_discard ] getDeclIdent :: Declaration -> Maybe Ident getDeclIdent = getIdentName <=< declName diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -15,7 +15,6 @@ import Control.Arrow (first, second) import Control.Monad (unless) import Control.Monad.Writer.Class -import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) @@ -237,7 +236,7 @@ -- checkExhaustive :: forall m - . (MonadWriter MultipleErrors m, MonadSupply m) + . MonadWriter MultipleErrors m => SourceSpan -> Environment -> ModuleName @@ -292,7 +291,7 @@ -- checkExhaustiveExpr :: forall m - . (MonadWriter MultipleErrors m, MonadSupply m) + . MonadWriter MultipleErrors m => SourceSpan -> Environment -> ModuleName diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -142,7 +142,7 @@ -- Checks whether a module is the Prim module - used to suppress any checks -- made, as Prim is always implicitly imported. isPrim :: ModuleName -> Bool - isPrim = (== C.Prim) + isPrim = (== C.M_Prim) -- Creates a map of virtual modules mapped to all the declarations that -- import to that module, with the corresponding source span, import type, diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -56,7 +56,7 @@ -- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples). rebuildModule :: forall m - . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [ExternsFile] -> Module @@ -67,7 +67,7 @@ rebuildModule' :: forall m - . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -77,7 +77,7 @@ rebuildModuleWithIndex :: forall m - . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> Env -> [ExternsFile] @@ -136,7 +136,7 @@ -- -- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without -- having to typecheck those modules again. -make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) +make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MakeActions m -> [CST.PartialResult Module] -> m [ExternsFile] diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -8,6 +8,7 @@ , cacheDbFile , readCacheDb' , writeCacheDb' + , ffiCodegen' ) where import Prelude @@ -280,23 +281,7 @@ ffiCodegen :: CF.Module CF.Ann -> Make () ffiCodegen m = do codegenTargets <- asks optionsCodegenTargets - when (S.member JS codegenTargets) $ do - let mn = CF.moduleName m - case mn `M.lookup` foreigns of - Just path - | not $ requiresForeign m -> - tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path - | otherwise -> do - checkResult <- checkForeignDecls m path - case checkResult of - Left _ -> copyFile path (outputFilename mn "foreign.js") - Right (ESModule, _) -> copyFile path (outputFilename mn "foreign.js") - Right (CJSModule, _) -> do - throwError $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path - - Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn - | otherwise -> return () - + ffiCodegen' foreigns codegenTargets (Just outputFilename) m genSourceMap :: String -> String -> Int -> [SMap] -> Make () genSourceMap dir mapFile extraLines mappings = do @@ -308,7 +293,7 @@ map (\(SMap _ orig gen) -> Mapping { mapOriginal = Just $ convertPos $ add 0 (-1) orig , mapSourceFile = sourceFile - , mapGenerated = convertPos $ add (extraLines+1) 0 gen + , mapGenerated = convertPos $ add (extraLines + 1) 0 gen , mapName = Nothing }) mappings } @@ -316,7 +301,7 @@ writeJSONFile mapFile mapping where add :: Int -> Int -> SourcePos -> SourcePos - add n m (SourcePos n' m') = SourcePos (n+n') (m+m') + add n m (SourcePos n' m') = SourcePos (n + n') (m + m') convertPos :: SourcePos -> Pos convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } = @@ -358,7 +343,7 @@ modSS = CF.moduleSourceSpan m checkFFI :: JS.JSAST -> Make (ForeignModuleType, S.Set Ident) - checkFFI js = do + checkFFI js = do (foreignModuleType, foreignIdentsStrs) <- case (,) <$> getForeignModuleExports js <*> getForeignModuleImports js of Left reason -> throwError $ errorParsingModule reason @@ -438,3 +423,33 @@ . CST.runTokenParser CST.parseIdent . CST.lex $ T.pack str + +-- | FFI check and codegen action. +-- If path maker is supplied copies foreign module to the output. +ffiCodegen' + :: M.Map ModuleName FilePath + -> S.Set CodegenTarget + -> Maybe (ModuleName -> String -> FilePath) + -> CF.Module CF.Ann + -> Make () +ffiCodegen' foreigns codegenTargets makeOutputPath m = do + when (S.member JS codegenTargets) $ do + let mn = CF.moduleName m + case mn `M.lookup` foreigns of + Just path + | not $ requiresForeign m -> + tell $ errorMessage' (CF.moduleSourceSpan m) $ UnnecessaryFFIModule mn path + | otherwise -> do + checkResult <- checkForeignDecls m path + case checkResult of + Left _ -> copyForeign path mn + Right (ESModule, _) -> copyForeign path mn + Right (CJSModule, _) -> do + throwError $ errorMessage' (CF.moduleSourceSpan m) $ DeprecatedFFICommonJSModule mn path + Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn + | otherwise -> return () + where + requiresForeign = not . null . CF.moduleForeign + + copyForeign path mn = + for_ makeOutputPath (\outputFilename -> copyFile path (outputFilename mn "foreign.js")) diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -127,7 +127,7 @@ -- The given MakeActions are used to collect various timestamps in order to -- determine whether a module needs rebuilding. construct - :: forall m. (Monad m, MonadBaseControl IO m) + :: forall m. MonadBaseControl IO m => MakeActions m -> CacheDb -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])]) diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -96,8 +96,8 @@ bumpPos p (SMap f s g) = SMap f s $ p `addPos` g addPos :: SourcePos -> SourcePos -> SourcePos -addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m+m') -addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m' +addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m + m') +addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n + n') m' data PrinterState = PrinterState { indent :: Int } diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -12,7 +12,7 @@ import Language.PureScript.AST import Language.PureScript.Errors import Language.PureScript.Names -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | Replace all @AdoNotationBind@ and @AdoNotationValue@ constructors with -- applications of the pure and apply functions in scope, and all @AdoNotationLet@ @@ -28,13 +28,13 @@ in rethrowWithPosition ss $ f d where pure' :: SourceSpan -> Maybe ModuleName -> Expr - pure' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.pure')) + pure' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_pure)) map' :: SourceSpan -> Maybe ModuleName -> Expr - map' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.map)) + map' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_map)) apply :: SourceSpan -> Maybe ModuleName -> Expr - apply ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.apply)) + apply ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_apply)) replace :: SourceSpan -> Expr -> m Expr replace pos (Ado m els yield) = do diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -14,7 +14,7 @@ import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with -- applications of the bind function in scope, and all @DoNotationLet@ @@ -30,10 +30,10 @@ in rethrowWithPosition ss $ f d where bind :: SourceSpan -> Maybe ModuleName -> Expr - bind ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.bind)) + bind ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_bind)) discard :: SourceSpan -> Maybe ModuleName -> Expr - discard ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.discard)) + discard ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_discard)) replace :: SourceSpan -> Expr -> m Expr replace pos (Do m els) = go pos m els @@ -57,7 +57,7 @@ go _ _ (DoNotationBind b _ : _) | First (Just ident) <- foldMap fromIdent (binderNames b) = throwError . errorMessage $ CannotUseBindWithDo (Ident ident) where - fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i) + fromIdent (Ident i) | i `elem` [ C.S_bind, C.S_discard ] = First (Just i) fromIdent _ = mempty go pos m (DoNotationBind binder val : rest) = do rest' <- go pos m rest @@ -75,7 +75,7 @@ go pos m (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () checkBind (ValueDecl (ss, _) i@(Ident name) _ _ _) - | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i + | name `elem` [ C.S_bind, C.S_discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds rest' <- go pos m rest diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -10,14 +10,15 @@ ) where import Prelude -import Protolude (ordNub, sortOn, swap, foldl') +import Protolude (sortOn, swap, foldl') -import Control.Arrow (first, second) +import Control.Arrow (first, second, (&&&)) import Control.Monad import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Lazy import Control.Monad.Writer (MonadWriter(..)) +import qualified Data.List.NonEmpty as NEL import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Set as S @@ -253,9 +254,15 @@ updateValue (pos, bound) (Abs (VarBinder ss arg) val') = return ((pos, M.insert arg (spanStart ss) bound), Abs (VarBinder ss arg) val') updateValue (pos, bound) (Let w ds val') = do - let args = mapMaybe letBoundVariable ds - unless (length (ordNub args) == length args) . - throwError . errorMessage' pos $ OverlappingNamesInLet + let + args = mapMaybe letBoundVariable ds + groupByFst = map (\ts -> (fst (NEL.head ts), snd <$> ts)) . NEL.groupAllWith fst + duplicateArgsErrs = foldMap mkArgError $ groupByFst args + mkArgError (ident, poses) + | NEL.length poses < 2 = mempty + | otherwise = errorMessage'' (NEL.reverse poses) (OverlappingNamesInLet ident) + when (nonEmpty duplicateArgsErrs) $ + throwError duplicateArgsErrs return ((pos, declarationsToMap ds `M.union` bound), Let w ds val') updateValue (_, bound) (Var ss name'@(Qualified qualifiedBy ident)) = ((ss, bound), ) <$> case (M.lookup ident bound, qualifiedBy) of @@ -324,8 +331,8 @@ . fmap (second spanStart . swap) . binderNamesWithSpans - letBoundVariable :: Declaration -> Maybe Ident - letBoundVariable = fmap valdeclIdent . getValueDeclaration + letBoundVariable :: Declaration -> Maybe (Ident, SourceSpan) + letBoundVariable = fmap (valdeclIdent &&& (fst . valdeclSourceAnn)) . getValueDeclaration declarationsToMap :: [Declaration] -> M.Map Ident SourcePos declarationsToMap = foldl goDTM M.empty diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -40,7 +40,7 @@ -- but that requires additional changes in how warnings are printed. -- Example of keeping all duplicates (not what this code currently does): -- removeUnique [1,2,2,3,3,3,4] == [2,2,3,3,3] - removeUnique :: Eq a => Ord a => [a] -> [a] + removeUnique :: Ord a => [a] -> [a] removeUnique = concatMap (drop 1) . group . sort -- Deletes the constructor information from TypeRefs so that only the diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -246,31 +246,31 @@ -- | Environment which only contains the Prim modules. primEnv :: Env primEnv = M.fromList - [ ( C.Prim + [ ( C.M_Prim , (internalModuleSourceSpan "", nullImports, primExports) ) - , ( C.PrimBoolean + , ( C.M_Prim_Boolean , (internalModuleSourceSpan "", nullImports, primBooleanExports) ) - , ( C.PrimCoerce + , ( C.M_Prim_Coerce , (internalModuleSourceSpan "", nullImports, primCoerceExports) ) - , ( C.PrimOrdering + , ( C.M_Prim_Ordering , (internalModuleSourceSpan "", nullImports, primOrderingExports) ) - , ( C.PrimRow + , ( C.M_Prim_Row , (internalModuleSourceSpan "", nullImports, primRowExports) ) - , ( C.PrimRowList + , ( C.M_Prim_RowList , (internalModuleSourceSpan "", nullImports, primRowListExports) ) - , ( C.PrimSymbol + , ( C.M_Prim_Symbol , (internalModuleSourceSpan "", nullImports, primSymbolExports) ) - , ( C.PrimInt + , ( C.M_Prim_Int , (internalModuleSourceSpan "", nullImports, primIntExports) ) - , ( C.PrimTypeError + , ( C.M_Prim_TypeError , (internalModuleSourceSpan "", nullImports, primTypeErrorExports) ) ] diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -40,7 +40,7 @@ import qualified Data.Map as M import Data.Ord (Down(..)) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C -- | -- Removes unary negation operators and replaces them with calls to `negate`. @@ -50,7 +50,7 @@ Module ss coms mn (map f' ds) exts where (f', _, _) = everywhereOnValues id go id - go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.negate))) val + go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.S_negate))) val go other = other -- | @@ -184,7 +184,7 @@ -- | Indicates whether the `rebracketModule` -- is being called with the full desugar pass -- run via `purs compile` or whether --- only the partial desguar pass is run +-- only the partial desugar pass is run -- via `purs docs`. -- This indication is needed to prevent -- a `purs docs` error when using @@ -216,7 +216,7 @@ -- and only some of the desugar passes when generating docs. -- When generating docs, `case _ of` syntax used in an instance declaration -- can trigger the `IncorrectAnonymousArgument` error because it does not - -- run the same passes that the compile desguaring does. Since `purs docs` + -- run the same passes that the compile desugaring does. Since `purs docs` -- will only succeed once `purs compile` succeeds, we can ignore this check -- when running `purs docs`. -- See https://github.com/purescript/purescript/issues/4274#issuecomment-1087730651= diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -53,13 +53,13 @@ initialState :: MemberMap initialState = mconcat - [ M.mapKeys (qualify C.Prim) primClasses - , M.mapKeys (qualify C.PrimCoerce) primCoerceClasses - , M.mapKeys (qualify C.PrimRow) primRowClasses - , M.mapKeys (qualify C.PrimRowList) primRowListClasses - , M.mapKeys (qualify C.PrimSymbol) primSymbolClasses - , M.mapKeys (qualify C.PrimInt) primIntClasses - , M.mapKeys (qualify C.PrimTypeError) primTypeErrorClasses + [ M.mapKeys (qualify C.M_Prim) primClasses + , M.mapKeys (qualify C.M_Prim_Coerce) primCoerceClasses + , M.mapKeys (qualify C.M_Prim_Row) primRowClasses + , M.mapKeys (qualify C.M_Prim_RowList) primRowListClasses + , M.mapKeys (qualify C.M_Prim_Symbol) primSymbolClasses + , M.mapKeys (qualify C.M_Prim_Int) primIntClasses + , M.mapKeys (qualify C.M_Prim_TypeError) primTypeErrorClasses , M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) ] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -9,8 +9,7 @@ import Data.List (foldl', find, unzip5) import Language.PureScript.AST import Language.PureScript.AST.Utils -import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep -import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype +import qualified Language.PureScript.Constants.Libs as Libs import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors @@ -59,8 +58,8 @@ _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 in case className of - DataNewtype.Newtype -> binaryWildcardClass deriveNewtype - DataGenericRep.Generic -> binaryWildcardClass (deriveGenericRep ss mn) + Libs.Generic -> binaryWildcardClass (deriveGenericRep ss mn) + Libs.Newtype -> binaryWildcardClass deriveNewtype _ -> pure decl _ -> pure decl @@ -84,13 +83,13 @@ lamCase x [ CaseAlternative [NullBinder] - (unguarded (App (Var ss DataGenericRep.to) (Var ss' (Qualified ByNullSourcePos x)))) + (unguarded (App (Var ss Libs.I_to) (Var ss' (Qualified ByNullSourcePos x)))) ] , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] - (unguarded (App (Var ss DataGenericRep.from) (Var ss' (Qualified ByNullSourcePos x)))) + (unguarded (App (Var ss Libs.I_from) (Var ss' (Qualified ByNullSourcePos x)))) ] ] | otherwise = @@ -112,12 +111,12 @@ select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r] sumBinders :: Int -> [Binder -> Binder] - sumBinders = select (ConstructorBinder ss DataGenericRep.Inl . pure) - (ConstructorBinder ss DataGenericRep.Inr . pure) + sumBinders = select (ConstructorBinder ss Libs.C_Inl . pure) + (ConstructorBinder ss Libs.C_Inr . pure) sumExprs :: Int -> [Expr -> Expr] - sumExprs = select (App (Constructor ss DataGenericRep.Inl)) - (App (Constructor ss DataGenericRep.Inr)) + sumExprs = select (App (Constructor ss Libs.C_Inl)) + (App (Constructor ss Libs.C_Inr)) compN :: Int -> (a -> a) -> a -> a compN 0 _ = id @@ -129,37 +128,37 @@ makeInst (DataConstructorDeclaration _ ctorName args) = do let args' = map snd args (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' - return ( srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Constructor) + return ( srcTypeApp (srcTypeApp (srcTypeConstructor Libs.Constructor) (srcTypeLevelString $ mkString (runProperName ctorName))) ctorTy - , CaseAlternative [ ConstructorBinder ss DataGenericRep.Constructor [matchProduct] ] + , CaseAlternative [ ConstructorBinder ss Libs.C_Constructor [matchProduct] ] (unguarded (foldl' App (Constructor ss (Qualified (ByModuleName mn) ctorName)) ctorArgs)) , CaseAlternative [ ConstructorBinder ss (Qualified (ByModuleName mn) ctorName) matchCtor ] - (unguarded (App (Constructor ss DataGenericRep.Constructor) mkProduct)) + (unguarded (App (Constructor ss Libs.C_Constructor) mkProduct)) ) makeProduct :: [SourceType] -> m (SourceType, Binder, [Expr], [Binder], Expr) makeProduct [] = - pure (srcTypeConstructor DataGenericRep.NoArguments, NullBinder, [], [], Constructor ss DataGenericRep.NoArguments) + pure (srcTypeConstructor Libs.NoArguments, NullBinder, [], [], Constructor ss Libs.C_NoArguments) makeProduct args = do (tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args - pure ( foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Product) f)) tys - , foldr1 (\b1 b2 -> ConstructorBinder ss DataGenericRep.Product [b1, b2]) bs1 + pure ( foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor Libs.Product) f)) tys + , foldr1 (\b1 b2 -> ConstructorBinder ss Libs.C_Product [b1, b2]) bs1 , es1 , bs2 - , foldr1 (\e1 -> App (App (Constructor ss DataGenericRep.Product) e1)) es2 + , foldr1 (\e1 -> App (App (Constructor ss Libs.C_Product) e1)) es2 ) makeArg :: SourceType -> m (SourceType, Binder, Expr, Binder, Expr) makeArg arg = do argName <- freshIdent "arg" - pure ( srcTypeApp (srcTypeConstructor DataGenericRep.Argument) arg - , ConstructorBinder ss DataGenericRep.Argument [ VarBinder ss argName ] + pure ( srcTypeApp (srcTypeConstructor Libs.Argument) arg + , ConstructorBinder ss Libs.C_Argument [ VarBinder ss argName ] , Var ss (Qualified (BySourcePos $ spanStart ss) argName) , VarBinder ss argName - , App (Constructor ss DataGenericRep.Argument) (Var ss (Qualified (BySourcePos $ spanStart ss) argName)) + , App (Constructor ss Libs.C_Argument) (Var ss (Qualified (BySourcePos $ spanStart ss) argName)) ) underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative @@ -170,9 +169,9 @@ underExpr _ _ = internalError "underExpr: expected unguarded alternative" toRepTy :: [SourceType] -> SourceType - toRepTy [] = srcTypeConstructor DataGenericRep.NoConstructors + toRepTy [] = srcTypeConstructor Libs.NoConstructors toRepTy [only] = only - toRepTy ctors = foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor DataGenericRep.Sum) f)) ctors + toRepTy ctors = foldr1 (\f -> srcTypeApp (srcTypeApp (srcTypeConstructor Libs.Sum) f)) ctors checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> SourceType -> m () checkIsWildcard _ _ (TypeWildcard _ UnnamedWildcard) = return () diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -29,8 +29,7 @@ import Language.PureScript.AST import Language.PureScript.AST.Declarations.ChainId (ChainId) -import qualified Language.PureScript.Constants.Data.Generic.Rep as DataGenericRep -import qualified Language.PureScript.Constants.Data.Newtype as DataNewtype +import qualified Language.PureScript.Constants.Libs as Libs import Language.PureScript.Crash import Language.PureScript.Environment import Language.PureScript.Errors @@ -789,8 +788,8 @@ checkDataConstructorsAreExported :: DeclarationRef -> m () checkDataConstructorsAreExported dr@(TypeRef ss' name (fromMaybe [] -> exportedDataConstructorsNames)) | null exportedDataConstructorsNames = for_ - [ DataGenericRep.Generic - , DataNewtype.Newtype + [ Libs.Generic + , Libs.Newtype ] $ \className -> do env <- getEnv let dicts = foldMap (foldMap NEL.toList) $ diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -5,18 +5,20 @@ import Protolude hiding (Type) +import Control.Lens (both, over) +import Control.Monad.Error.Class (liftEither) import Control.Monad.Trans.Writer (Writer, WriterT, runWriter, runWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) +import Data.Align (align, unalign) import Data.Foldable (foldl1, foldr1) import Data.List (init, last, zipWith3, (!!)) import qualified Data.Map as M +import Data.These (These(..), mergeTheseWith, these) import Control.Monad.Supply.Class import Language.PureScript.AST import Language.PureScript.AST.Utils -import qualified Language.PureScript.Constants.Data.Foldable as Foldable -import qualified Language.PureScript.Constants.Data.Traversable as Traversable -import qualified Language.PureScript.Constants.Prelude as Prelude +import qualified Language.PureScript.Constants.Libs as Libs import qualified Language.PureScript.Constants.Prim as Prim import Language.PureScript.Crash import Language.PureScript.Environment @@ -25,6 +27,7 @@ import Language.PureScript.Names import Language.PureScript.PSString import Language.PureScript.Sugar.TypeClasses +import Language.PureScript.TypeChecker.Entailment import Language.PureScript.TypeChecker.Monad import Language.PureScript.TypeChecker.Synonyms import Language.PureScript.TypeClassDictionaries @@ -78,13 +81,18 @@ unaryClass' f = unaryClass (f className) in case className of - Foldable.Foldable -> unaryClass' deriveFoldable - Prelude.Eq -> unaryClass deriveEq - Prelude.Eq1 -> unaryClass $ \_ _ -> deriveEq1 - Prelude.Functor -> unaryClass' deriveFunctor - Prelude.Ord -> unaryClass deriveOrd - Prelude.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 - Traversable.Traversable -> unaryClass' deriveTraversable + Libs.Bifoldable -> unaryClass' $ deriveFoldable True + Libs.Bifunctor -> unaryClass' $ deriveFunctor (Just False) False Libs.S_bimap + Libs.Bitraversable -> unaryClass' $ deriveTraversable True + Libs.Contravariant -> unaryClass' $ deriveFunctor Nothing True Libs.S_cmap + Libs.Eq -> unaryClass deriveEq + Libs.Eq1 -> unaryClass $ \_ _ -> deriveEq1 + Libs.Foldable -> unaryClass' $ deriveFoldable False + Libs.Functor -> unaryClass' $ deriveFunctor Nothing False Libs.S_map + Libs.Ord -> unaryClass deriveOrd + Libs.Ord1 -> unaryClass $ \_ _ -> deriveOrd1 + Libs.Profunctor -> unaryClass' $ deriveFunctor (Just True) False Libs.S_dimap + Libs.Traversable -> unaryClass' $ deriveTraversable False -- See L.P.Sugar.TypeClasses.Deriving for the classes that can be -- derived prior to type checking. _ -> throwError . errorMessage $ CannotDerive className tys @@ -101,7 +109,6 @@ :: forall m . MonadError MultipleErrors m => MonadState CheckState m - => MonadSupply m => MonadWriter MultipleErrors m => ModuleName -> Qualified (ProperName 'ClassName) @@ -194,7 +201,7 @@ deriveEq mn tyConNm = do (_, _, _, ctors) <- lookupTypeDecl mn tyConNm eqFun <- mkEqFunction ctors - pure [(Prelude.eq, eqFun)] + pure [(Libs.S_eq, eqFun)] where mkEqFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr mkEqFunction ctors = do @@ -203,13 +210,13 @@ lamCase2 x y . addCatch <$> mapM mkCtorClause ctors preludeConj :: Expr -> Expr -> Expr - preludeConj = App . App (mkVarMn (Just (ModuleName "Data.HeytingAlgebra")) (Ident Prelude.conj)) + preludeConj = App . App (mkRef Libs.I_conj) preludeEq :: Expr -> Expr -> Expr - preludeEq = App . App (mkRef Prelude.identEq) + preludeEq = App . App (mkRef Libs.I_eq) preludeEq1 :: Expr -> Expr -> Expr - preludeEq1 = App . App (mkRef Prelude.identEq1) + preludeEq1 = App . App (mkRef Libs.I_eq1) addCatch :: [CaseAlternative] -> [CaseAlternative] addCatch xs @@ -243,7 +250,7 @@ | otherwise = preludeEq l r deriveEq1 :: forall m. Applicative m => m [(PSString, Expr)] -deriveEq1 = pure [(Prelude.eq1, mkRef Prelude.identEq)] +deriveEq1 = pure [(Libs.S_eq1, mkRef Libs.I_eq)] deriveOrd :: forall m @@ -256,7 +263,7 @@ deriveOrd mn tyConNm = do (_, _, _, ctors) <- lookupTypeDecl mn tyConNm compareFun <- mkCompareFunction ctors - pure [(Prelude.compare, compareFun)] + pure [(Libs.S_compare, compareFun)] where mkCompareFunction :: [(ProperName 'ConstructorName, [SourceType])] -> m Expr mkCompareFunction ctors = do @@ -286,10 +293,10 @@ orderingBinder name = mkCtorBinder orderingMod (ProperName name) [] ordCompare :: Expr -> Expr -> Expr - ordCompare = App . App (mkRef Prelude.identCompare) + ordCompare = App . App (mkRef Libs.I_compare) ordCompare1 :: Expr -> Expr -> Expr - ordCompare1 = App . App (mkRef Prelude.identCompare1) + ordCompare1 = App . App (mkRef Libs.I_compare1) mkCtorClauses :: ((ProperName 'ConstructorName, [SourceType]), Bool) -> m [CaseAlternative] mkCtorClauses ((ctorName, tys), isLast) = do @@ -330,7 +337,7 @@ | otherwise = ordCompare l r deriveOrd1 :: forall m. Applicative m => m [(PSString, Expr)] -deriveOrd1 = pure [(Prelude.compare1, mkRef Prelude.identCompare)] +deriveOrd1 = pure [(Libs.S_compare1, mkRef Libs.I_compare)] lookupTypeDecl :: forall m @@ -369,78 +376,183 @@ where go (RCons _ str typ typs) = (str, typ) : go typs go _ = [] -data ParamUsage +-- | The parameter `c` is used to allow or forbid contravariance for different +-- type classes. When deriving a type class that is a variation on Functor, a +-- witness for `c` will be provided; when deriving a type class that is a +-- variation on Foldable or Traversable, `c` will be Void and the contravariant +-- ParamUsage constructor can be skipped in pattern matching. +data ParamUsage c = IsParam - | MentionsParam ParamUsage - | IsRecord (NonEmpty (PSString, ParamUsage)) + | IsLParam + -- ^ enables biparametric classes (of any variance) to be derived + | MentionsParam (ParamUsage c) + -- ^ enables monoparametric classes to be used in a derivation + | MentionsParamBi (These (ParamUsage c) (ParamUsage c)) + -- ^ enables biparametric classes to be used in a derivation + | MentionsParamContravariantly !c (ContravariantParamUsage c) + -- ^ enables contravariant classes (of either parametricity) to be used in a derivation + | IsRecord (NonEmpty (PSString, ParamUsage c)) +data ContravariantParamUsage c + = MentionsParamContra (ParamUsage c) + -- ^ enables Contravariant to be used in a derivation + | MentionsParamPro (These (ParamUsage c) (ParamUsage c)) + -- ^ enables Profunctor to be used in a derivation + +data CovariantClasses = CovariantClasses + { monoClass :: Qualified (ProperName 'ClassName) + , biClass :: Qualified (ProperName 'ClassName) + } + +data ContravariantClasses = ContravariantClasses + { contraClass :: Qualified (ProperName 'ClassName) + , proClass :: Qualified (ProperName 'ClassName) + } + +data ContravarianceSupport c = ContravarianceSupport + { contravarianceWitness :: c + , paramIsContravariant :: Bool + , lparamIsContravariant :: Bool + , contravariantClasses :: ContravariantClasses + } + +-- | Return, if possible, a These the contents of which each satisfy the +-- predicate. +filterThese :: forall a. (a -> Bool) -> These a a -> Maybe (These a a) +filterThese p = uncurry align . over both (mfilter p) . unalign . Just + validateParamsInTypeConstructors - :: forall m + :: forall c m . MonadError MultipleErrors m => MonadState CheckState m => Qualified (ProperName 'ClassName) -> ModuleName -> ProperName 'TypeName - -> m [(ProperName 'ConstructorName, [Maybe ParamUsage])] -validateParamsInTypeConstructors derivingClass mn tyConNm = do + -> Bool + -> CovariantClasses + -> Maybe (ContravarianceSupport c) + -> m [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] +validateParamsInTypeConstructors derivingClass mn tyConNm isBi CovariantClasses{..} contravarianceSupport = do (_, _, tyArgNames, ctors) <- lookupTypeDecl mn tyConNm - param <- note (errorMessage $ KindsDoNotUnify (kindType -:> kindType) kindType) . lastMay $ map fst tyArgNames + (mbLParam, param) <- liftEither . first (errorMessage . flip KindsDoNotUnify kindType . (kindType -:>)) $ + case (isBi, reverse $ map fst tyArgNames) of + (False, x : _) -> Right (Nothing, x) + (False, _) -> Left kindType + (True, y : x : _) -> Right (Just x, y) + (True, _ : _) -> Left kindType + (True, _) -> Left $ kindType -:> kindType ctors' <- traverse (traverse $ traverse replaceAllTypeSynonyms) ctors - let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf param) ctors' + tcds <- getTypeClassDictionaries + let (ctorUsages, problemSpans) = runWriter $ traverse (traverse . traverse $ typeToUsageOf tcds (maybe That These mbLParam param) False) ctors' + let relatedClasses = [monoClass, biClass] ++ ([contraClass, proClass] <*> (contravariantClasses <$> toList contravarianceSupport)) for_ (nonEmpty $ ordNub problemSpans) $ \sss -> - throwError . addHint (RelatedPositions sss) . errorMessage $ CannotDeriveInvalidConstructorArg derivingClass + throwError . addHint (RelatedPositions sss) . errorMessage $ CannotDeriveInvalidConstructorArg derivingClass relatedClasses (isJust contravarianceSupport) pure ctorUsages + where - typeToUsageOf :: Text -> SourceType -> Writer [SourceSpan] (Maybe ParamUsage) - typeToUsageOf param = go - where + typeToUsageOf :: InstanceContext -> These Text Text -> Bool -> SourceType -> Writer [SourceSpan] (Maybe (ParamUsage c)) + typeToUsageOf tcds = fix $ \go params isNegative -> let + goCo = go params isNegative + goContra = go params $ not isNegative + assertNoParamUsedIn :: SourceType -> Writer [SourceSpan] () - assertNoParamUsedIn = everythingOnTypes (*>) $ \case + assertNoParamUsedIn ty = void $ both (flip assertParamNotUsedIn ty) params + + assertParamNotUsedIn :: Text -> SourceType -> Writer [SourceSpan] () + assertParamNotUsedIn param = everythingOnTypes (*>) $ \case TypeVar (ss, _) name | name == param -> tell [ss] _ -> pure () - go = \case + tryBiClasses ht tyLArg tyArg + | hasInstance tcds ht biClass + = goCo tyLArg >>= preferMonoClass MentionsParamBi + | Just (ContravarianceSupport c _ _ ContravariantClasses{..}) <- contravarianceSupport, hasInstance tcds ht proClass + = goContra tyLArg >>= preferMonoClass (MentionsParamContravariantly c . MentionsParamPro) + | otherwise + = assertNoParamUsedIn tyLArg *> tryMonoClasses ht tyArg + where + preferMonoClass f lUsage = + (if isNothing lUsage && hasInstance tcds ht monoClass then fmap MentionsParam else fmap f . align lUsage) <$> goCo tyArg + + tryMonoClasses ht tyArg + | hasInstance tcds ht monoClass + = fmap MentionsParam <$> goCo tyArg + | Just (ContravarianceSupport c _ _ ContravariantClasses{..}) <- contravarianceSupport, hasInstance tcds ht contraClass + = fmap (MentionsParamContravariantly c . MentionsParamContra) <$> goContra tyArg + | otherwise + = assertNoParamUsedIn tyArg $> Nothing + + in \case ForAll _ name _ ty _ -> - if name == param then pure Nothing else go ty + fmap join . traverse (\params' -> go params' isNegative ty) $ filterThese (/= name) params ConstrainedType _ _ ty -> - go ty + goCo ty TypeApp _ (TypeConstructor _ Prim.Record) row -> fmap (fmap IsRecord . nonEmpty . catMaybes) . for (decomposeRec' row) $ \(Label lbl, ty) -> - fmap (lbl, ) <$> go ty + fmap (lbl, ) <$> goCo ty - TypeApp _ tyFn tyArg -> do - assertNoParamUsedIn tyFn - fmap MentionsParam <$> go tyArg + TypeApp _ (TypeApp _ tyFn tyLArg) tyArg -> + assertNoParamUsedIn tyFn *> tryBiClasses (headOfType tyFn) tyLArg tyArg - TypeVar _ name -> - pure $ (name == param) `orEmpty` IsParam + TypeApp _ tyFn tyArg -> + assertNoParamUsedIn tyFn *> tryMonoClasses (headOfType tyFn) tyArg + TypeVar (ss, _) name -> mergeTheseWith (checkName lparamIsContra IsLParam) (checkName paramIsContra IsParam) (liftA2 (<|>)) params + where + checkName thisParamIsContra usage param + | name == param = when (thisParamIsContra /= isNegative) (tell [ss]) $> Just usage + | otherwise = pure Nothing + ty -> assertNoParamUsedIn ty $> Nothing + paramIsContra = any paramIsContravariant contravarianceSupport + lparamIsContra = any lparamIsContravariant contravarianceSupport + + hasInstance :: InstanceContext -> Qualified (Either Text (ProperName 'TypeName)) -> Qualified (ProperName 'ClassName) -> Bool + hasInstance tcds ht@(Qualified qb _) cn@(Qualified cqb _) = + any tcdAppliesToType $ concatMap (findDicts tcds cn) (ordNub [ByNullSourcePos, cqb, qb]) + where + tcdAppliesToType tcd = case tcdInstanceTypes tcd of + [headOfType -> ht'] -> ht == ht' + -- ^ It's possible that, if ht and ht' are Lefts, this might require + -- verifying that the name isn't shadowed by something in tcdForAll. I + -- can't devise a legal program that causes this issue, but if in the + -- future it seems like a good idea, it probably is. + _ -> False + + headOfType :: SourceType -> Qualified (Either Text (ProperName 'TypeName)) + headOfType = fix $ \go -> \case + TypeApp _ ty _ -> go ty + KindApp _ ty _ -> go ty + TypeVar _ nm -> Qualified ByNullSourcePos (Left nm) + Skolem _ nm _ _ _ -> Qualified ByNullSourcePos (Left nm) + TypeConstructor _ (Qualified qb nm) -> Qualified qb (Right nm) + ty -> internalError $ "headOfType missing a case: " <> show (void ty) + usingLamIdent :: forall m. MonadSupply m => (Expr -> m Expr) -> m Expr usingLamIdent cb = do ident <- freshIdent "v" lam ident <$> cb (mkVar ident) -traverseFields :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> NonEmpty (PSString, ParamUsage) -> Expr -> f Expr +traverseFields :: forall c f. Applicative f => (ParamUsage c -> Expr -> f Expr) -> NonEmpty (PSString, ParamUsage c) -> Expr -> f Expr traverseFields f fields r = fmap (ObjectUpdate r) . for (toList fields) $ \(lbl, usage) -> (lbl, ) <$> f usage (Accessor lbl r) -unnestRecords :: forall f. Applicative f => (ParamUsage -> Expr -> f Expr) -> ParamUsage -> Expr -> f Expr +unnestRecords :: forall c f. Applicative f => (ParamUsage c -> Expr -> f Expr) -> ParamUsage c -> Expr -> f Expr unnestRecords f = fix $ \go -> \case IsRecord fields -> traverseFields go fields usage -> f usage mkCasesForTraversal - :: forall f m + :: forall c f m . Applicative f -- this effect distinguishes the semantics of maps, folds, and traversals => MonadSupply m => ModuleName - -> (ParamUsage -> Expr -> f Expr) -- how to handle constructor arguments + -> (ParamUsage c -> Expr -> f Expr) -- how to handle constructor arguments -> (f Expr -> m Expr) -- resolve the applicative effect into an expression - -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] + -> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] -> m Expr mkCasesForTraversal mn handleArg extractExpr ctors = do m <- freshIdent "m" @@ -451,51 +563,107 @@ fmap (CaseAlternative [caseBinder] . unguarded) . extractExpr $ fmap (foldl' App ctor) . for ctorArgs $ \(ident, mbUsage) -> maybe pure handleArg mbUsage $ mkVar ident +data TraversalExprs = TraversalExprs + { recurseVar :: Expr -- a var representing map, foldMap, or traverse, for handling structured values + , birecurseVar :: Expr -- same, but bimap, bifoldMap, or bitraverse + , lrecurseExpr :: Expr -- same, but lmap or ltraverse (there is no lfoldMap, but we can use `flip bifoldMap mempty`) + , rrecurseExpr :: Expr -- same, but rmap or rtraverse etc., which conceptually should be the same as recurseVar but the bi classes aren't subclasses of the mono classes + } + +data ContraversalExprs = ContraversalExprs + { crecurseVar :: Expr + , direcurseVar :: Expr + , lcrecurseVar :: Expr + , rprorecurseVar :: Expr + } + +appBirecurseExprs :: TraversalExprs -> These Expr Expr -> Expr +appBirecurseExprs TraversalExprs{..} = these (App lrecurseExpr) (App rrecurseExpr) (App . App birecurseVar) + +appDirecurseExprs :: ContraversalExprs -> These Expr Expr -> Expr +appDirecurseExprs ContraversalExprs{..} = these (App lcrecurseVar) (App rprorecurseVar) (App . App direcurseVar) + data TraversalOps m = forall f. Applicative f => TraversalOps { visitExpr :: m Expr -> f Expr -- lift an expression into the applicative effect defining the traversal , extractExpr :: f Expr -> m Expr -- resolve the applicative effect into an expression } mkTraversal - :: forall m + :: forall c m . MonadSupply m => ModuleName - -> Expr -- a var representing map, foldMap, or traverse, for handling structured values + -> Bool + -> TraversalExprs + -> (c -> ContraversalExprs) -> TraversalOps m - -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] + -> [(ProperName 'ConstructorName, [Maybe (ParamUsage c)])] -> m Expr -mkTraversal mn recurseVar (TraversalOps @_ @f visitExpr extractExpr) ctors = do +mkTraversal mn isBi te@TraversalExprs{..} getContraversalExprs (TraversalOps @_ @f visitExpr extractExpr) ctors = do f <- freshIdent "f" + g <- if isBi then freshIdent "g" else pure f let - handleValue :: ParamUsage -> Expr -> f Expr + handleValue :: ParamUsage c -> Expr -> f Expr handleValue = unnestRecords $ \usage inputExpr -> visitExpr $ flip App inputExpr <$> mkFnExprForValue usage - mkFnExprForValue :: ParamUsage -> m Expr + mkFnExprForValue :: ParamUsage c -> m Expr mkFnExprForValue = \case IsParam -> + pure $ mkVar g + IsLParam -> pure $ mkVar f MentionsParam innerUsage -> App recurseVar <$> mkFnExprForValue innerUsage + MentionsParamBi theseInnerUsages -> + appBirecurseExprs te <$> both mkFnExprForValue theseInnerUsages + MentionsParamContravariantly c contraUsage -> do + let ce@ContraversalExprs{..} = getContraversalExprs c + case contraUsage of + MentionsParamContra innerUsage -> + App crecurseVar <$> mkFnExprForValue innerUsage + MentionsParamPro theseInnerUsages -> + appDirecurseExprs ce <$> both mkFnExprForValue theseInnerUsages IsRecord fields -> usingLamIdent $ extractExpr . traverseFields handleValue fields - lam f <$> mkCasesForTraversal mn handleValue extractExpr ctors + lam f . applyWhen isBi (lam g) <$> mkCasesForTraversal mn handleValue extractExpr ctors deriveFunctor :: forall m . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => Qualified (ProperName 'ClassName) + => Maybe Bool -- does left parameter exist, and is it contravariant? + -> Bool -- is the (right) parameter contravariant? + -> PSString -- name of the map function for this functor type + -> Qualified (ProperName 'ClassName) -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveFunctor nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm - mapFun <- mkTraversal mn mapVar (TraversalOps identity identity) ctors - pure [(Prelude.map, mapFun)] +deriveFunctor mbLParamIsContravariant paramIsContravariant mapName nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi functorClasses $ Just $ ContravarianceSupport + { contravarianceWitness = () + , paramIsContravariant + , lparamIsContravariant = or mbLParamIsContravariant + , contravariantClasses + } + mapFun <- mkTraversal mn isBi mapExprs (const cmapExprs) (TraversalOps identity identity) ctors + pure [(mapName, mapFun)] where - mapVar = mkRef Prelude.identMap + isBi = isJust mbLParamIsContravariant + mapExprs = TraversalExprs + { recurseVar = mkRef Libs.I_map + , birecurseVar = mkRef Libs.I_bimap + , lrecurseExpr = mkRef Libs.I_lmap + , rrecurseExpr = mkRef Libs.I_rmap + } + cmapExprs = ContraversalExprs + { crecurseVar = mkRef Libs.I_cmap + , direcurseVar = mkRef Libs.I_dimap + , lcrecurseVar = mkRef Libs.I_lcmap + , rprorecurseVar = mkRef Libs.I_profunctorRmap + } + functorClasses = CovariantClasses Libs.Functor Libs.Bifunctor + contravariantClasses = ContravariantClasses Libs.Contravariant Libs.Profunctor toConst :: forall f a b. f a -> Const [f a] b toConst = Const . pure @@ -511,42 +679,74 @@ . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => Qualified (ProperName 'ClassName) + => Bool -- is there a left parameter (are we deriving Bifoldable)? + -> Qualified (ProperName 'ClassName) -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveFoldable nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm - foldlFun <- mkAsymmetricFoldFunction False foldlVar ctors - foldrFun <- mkAsymmetricFoldFunction True foldrVar ctors - foldMapFun <- mkTraversal mn foldMapVar foldMapOps ctors - pure [(Foldable.foldl, foldlFun), (Foldable.foldr, foldrFun), (Foldable.foldMap, foldMapFun)] +deriveFoldable isBi nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi foldableClasses Nothing + foldlFun <- mkAsymmetricFoldFunction False foldlExprs ctors + foldrFun <- mkAsymmetricFoldFunction True foldrExprs ctors + foldMapFun <- mkTraversal mn isBi foldMapExprs absurd foldMapOps ctors + pure + [ (if isBi then Libs.S_bifoldl else Libs.S_foldl, foldlFun) + , (if isBi then Libs.S_bifoldr else Libs.S_foldr, foldrFun) + , (if isBi then Libs.S_bifoldMap else Libs.S_foldMap, foldMapFun) + ] where - foldlVar = mkRef Foldable.identFoldl - foldrVar = mkRef Foldable.identFoldr - foldMapVar = mkRef Foldable.identFoldMap - flipVar = mkRef Prelude.identFlip + foldableClasses = CovariantClasses Libs.Foldable Libs.Bifoldable + foldlExprs = TraversalExprs + { recurseVar = mkRef Libs.I_foldl + , birecurseVar = bifoldlVar + , lrecurseExpr = App (App flipVar bifoldlVar) constVar + , rrecurseExpr = App bifoldlVar constVar + } + foldrExprs = TraversalExprs + { recurseVar = mkRef Libs.I_foldr + , birecurseVar = bifoldrVar + , lrecurseExpr = App (App flipVar bifoldrVar) (App constVar identityVar) + , rrecurseExpr = App bifoldrVar (App constVar identityVar) + } + foldMapExprs = TraversalExprs + { recurseVar = mkRef Libs.I_foldMap + , birecurseVar = bifoldMapVar + , lrecurseExpr = App (App flipVar bifoldMapVar) memptyVar + , rrecurseExpr = App bifoldMapVar memptyVar + } + bifoldlVar = mkRef Libs.I_bifoldl + bifoldrVar = mkRef Libs.I_bifoldr + bifoldMapVar = mkRef Libs.I_bifoldMap + constVar = mkRef Libs.I_const + flipVar = mkRef Libs.I_flip + identityVar = mkRef Libs.I_identity + memptyVar = mkRef Libs.I_mempty - mkAsymmetricFoldFunction :: Bool -> Expr -> [(ProperName 'ConstructorName, [Maybe ParamUsage])] -> m Expr - mkAsymmetricFoldFunction isRightFold recurseVar ctors = do + mkAsymmetricFoldFunction :: Bool -> TraversalExprs -> [(ProperName 'ConstructorName, [Maybe (ParamUsage Void)])] -> m Expr + mkAsymmetricFoldFunction isRightFold te@TraversalExprs{..} ctors = do f <- freshIdent "f" + g <- if isBi then freshIdent "g" else pure f z <- freshIdent "z" let appCombiner :: (Bool, Expr) -> Expr -> Expr -> Expr appCombiner (isFlipped, fn) = applyWhen (isFlipped == isRightFold) flip $ App . App fn - mkCombinerExpr :: ParamUsage -> m Expr + mkCombinerExpr :: ParamUsage Void -> m Expr mkCombinerExpr = fmap (uncurry $ \isFlipped -> applyWhen isFlipped $ App flipVar) . getCombiner - handleValue :: ParamUsage -> Expr -> Const [m (Expr -> Expr)] Expr + handleValue :: ParamUsage Void -> Expr -> Const [m (Expr -> Expr)] Expr handleValue = unnestRecords $ \usage inputExpr -> toConst $ flip appCombiner inputExpr <$> getCombiner usage - getCombiner :: ParamUsage -> m (Bool, Expr) + getCombiner :: ParamUsage Void -> m (Bool, Expr) getCombiner = \case IsParam -> + pure (False, mkVar g) + IsLParam -> pure (False, mkVar f) MentionsParam innerUsage -> (isRightFold, ) . App recurseVar <$> mkCombinerExpr innerUsage + MentionsParamBi theseInnerUsages -> + (isRightFold, ) . appBirecurseExprs te <$> both mkCombinerExpr theseInnerUsages IsRecord fields -> do let foldFieldsOf = traverseFields handleValue fields fmap (False, ) . usingLamIdent $ \lVar -> @@ -558,13 +758,13 @@ extractExprStartingWith :: Expr -> Const [m (Expr -> Expr)] Expr -> m Expr extractExprStartingWith = consumeConst . if isRightFold then foldr ($) else foldl' (&) - lam f . lam z <$> mkCasesForTraversal mn handleValue (extractExprStartingWith $ mkVar z) ctors + lam f . applyWhen isBi (lam g) . lam z <$> mkCasesForTraversal mn handleValue (extractExprStartingWith $ mkVar z) ctors foldMapOps :: forall m. Applicative m => TraversalOps m foldMapOps = TraversalOps { visitExpr = toConst, .. } where - appendVar = mkRef Prelude.identAppend - memptyVar = mkRef Prelude.identMempty + appendVar = mkRef Libs.I_append + memptyVar = mkRef Libs.I_mempty extractExpr :: Const [m Expr] Expr -> m Expr extractExpr = consumeConst $ \case @@ -576,25 +776,37 @@ . MonadError MultipleErrors m => MonadState CheckState m => MonadSupply m - => Qualified (ProperName 'ClassName) + => Bool -- is there a left parameter (are we deriving Bitraversable)? + -> Qualified (ProperName 'ClassName) -> ModuleName -> ProperName 'TypeName -> m [(PSString, Expr)] -deriveTraversable nm mn tyConNm = do - ctors <- validateParamsInTypeConstructors nm mn tyConNm - traverseFun <- mkTraversal mn traverseVar traverseOps ctors - sequenceFun <- usingLamIdent $ pure . App (App traverseVar identityVar) - pure [(Traversable.traverse, traverseFun), (Traversable.sequence, sequenceFun)] +deriveTraversable isBi nm mn tyConNm = do + ctors <- validateParamsInTypeConstructors nm mn tyConNm isBi traversableClasses Nothing + traverseFun <- mkTraversal mn isBi traverseExprs absurd traverseOps ctors + sequenceFun <- usingLamIdent $ pure . App (App (if isBi then App bitraverseVar identityVar else traverseVar) identityVar) + pure + [ (if isBi then Libs.S_bitraverse else Libs.S_traverse, traverseFun) + , (if isBi then Libs.S_bisequence else Libs.S_sequence, sequenceFun) + ] where - traverseVar = mkRef Traversable.identTraverse - identityVar = mkRef Prelude.identIdentity + traversableClasses = CovariantClasses Libs.Traversable Libs.Bitraversable + traverseExprs = TraversalExprs + { recurseVar = traverseVar + , birecurseVar = bitraverseVar + , lrecurseExpr = mkRef Libs.I_ltraverse + , rrecurseExpr = mkRef Libs.I_rtraverse + } + traverseVar = mkRef Libs.I_traverse + bitraverseVar = mkRef Libs.I_bitraverse + identityVar = mkRef Libs.I_identity traverseOps :: forall m. MonadSupply m => TraversalOps m traverseOps = TraversalOps { .. } where - pureVar = mkRef Prelude.identPure - mapVar = mkRef Prelude.identMap - applyVar = mkRef Prelude.identApply + pureVar = mkRef Libs.I_pure + mapVar = mkRef Libs.I_map + applyVar = mkRef Libs.I_apply visitExpr :: m Expr -> WriterT [(Ident, m Expr)] m Expr visitExpr traversedExpr = do diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -7,6 +7,7 @@ , replaceTypeClassDictionaries , newDictionaries , entails + , findDicts ) where import Prelude @@ -47,7 +48,7 @@ import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString, mkString, decodeString) -import qualified Language.PureScript.Constants.Prelude as C +import qualified Language.PureScript.Constants.Libs as C import qualified Language.PureScript.Constants.Prim as C -- | Describes what sort of dictionary to generate for type class instances @@ -77,9 +78,9 @@ ReflectableString s -> Literal NullSourceSpan $ StringLiteral s ReflectableBoolean b -> Literal NullSourceSpan $ BooleanLiteral b ReflectableOrdering o -> Constructor NullSourceSpan $ case o of - LT -> C.LT - EQ -> C.EQ - GT -> C.GT + LT -> C.C_LT + EQ -> C.C_EQ + GT -> C.C_GT -- | Extract the identifier of a named instance namedInstanceIdentifier :: Evidence -> Maybe (Qualified Ident) @@ -94,6 +95,9 @@ (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NonEmpty NamedDict))) +findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> QualifiedBy -> [TypeClassDict] +findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (M.lookup cn <=< flip M.lookup ctx) + -- | A type substitution which makes an instance head match a list of types. -- -- Note: we store many types per type variable name. For any name, all types @@ -224,11 +228,8 @@ ctorModules (KindedType _ ty _) = ctorModules ty ctorModules _ = Nothing - findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> QualifiedBy -> [TypeClassDict] - findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (M.lookup cn <=< flip M.lookup ctx) - valUndefined :: Expr - valUndefined = Var nullSourceSpan (Qualified (ByModuleName C.Prim) (Ident C.undefined)) + valUndefined = Var nullSourceSpan C.I_undefined solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr solve = go 0 hints @@ -460,9 +461,9 @@ solveSymbolCompare :: [SourceType] -> Maybe [TypeClassDict] solveSymbolCompare [arg0@(TypeLevelString _ lhs), arg1@(TypeLevelString _ rhs), _] = let ordering = case compare lhs rhs of - LT -> C.orderingLT - EQ -> C.orderingEQ - GT -> C.orderingGT + LT -> C.LT + EQ -> C.EQ + GT -> C.GT args' = [arg0, arg1, srcTypeConstructor ordering] in Just [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.SymbolCompare [] [] args' Nothing Nothing] solveSymbolCompare _ = Nothing @@ -526,11 +527,11 @@ TypeLevelInt _ i -> pure (ReflectableInt i, tyInt) TypeLevelString _ s -> pure (ReflectableString s, tyString) TypeConstructor _ n - | n == C.booleanTrue -> pure (ReflectableBoolean True, tyBoolean) - | n == C.booleanFalse -> pure (ReflectableBoolean False, tyBoolean) - | n == C.orderingLT -> pure (ReflectableOrdering LT, srcTypeConstructor C.Ordering) - | n == C.orderingEQ -> pure (ReflectableOrdering EQ, srcTypeConstructor C.Ordering) - | n == C.orderingGT -> pure (ReflectableOrdering GT, srcTypeConstructor C.Ordering) + | n == C.True -> pure (ReflectableBoolean True, tyBoolean) + | n == C.False -> pure (ReflectableBoolean False, tyBoolean) + | n == C.LT -> pure (ReflectableOrdering LT, srcTypeConstructor C.Ordering) + | n == C.EQ -> pure (ReflectableOrdering EQ, srcTypeConstructor C.Ordering) + | n == C.GT -> pure (ReflectableOrdering GT, srcTypeConstructor C.Ordering) _ -> Nothing pure [TypeClassDictionaryInScope Nothing 0 (ReflectableInstance ref) [] C.Reflectable [] [] [typeLevel, typ] Nothing Nothing] solveReflectable _ = Nothing @@ -554,9 +555,9 @@ solveIntCompare :: InstanceContext -> [SourceType] -> Maybe [TypeClassDict] solveIntCompare _ [arg0@(TypeLevelInt _ a), arg1@(TypeLevelInt _ b), _] = let ordering = case compare a b of - EQ -> C.orderingEQ - LT -> C.orderingLT - GT -> C.orderingGT + EQ -> C.EQ + LT -> C.LT + GT -> C.GT args' = [arg0, arg1, srcTypeConstructor ordering] in pure [TypeClassDictionaryInScope Nothing 0 EmptyClassInstance [] C.IntCompare [] [] args' Nothing Nothing] solveIntCompare ctx args@[a, b, _] = do diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -373,8 +373,8 @@ -- | A canonical constraint of the form @Coercible tv1 ty1@ can rewrite the -- right hand side of an irreducible constraint of the form @Coercible tv2 ty2@ --- by substituting @ty1@ for every occurence of @tv1@ at representational and --- phantom role in @ty2@. Nominal occurences are left untouched. +-- by substituting @ty1@ for every occurrence of @tv1@ at representational and +-- phantom role in @ty2@. Nominal occurrences are left untouched. rewrite :: Environment -> (SourceType, SourceType) -> SourceType -> Writer Any SourceType rewrite env (Skolem _ _ _ s1 _, ty1) | not $ occurs s1 ty1 = go where go (Skolem _ _ _ s2 _) | s1 == s2 = tell (Any True) $> ty1 @@ -506,7 +506,7 @@ -- -- yield the wanted @Coercible (N Maybe a) (N Maybe b)@ which we cannot -- decompose because the second parameter of @N@ is nominal. On the other - -- hand, unwraping on both sides yields @Coercible (Maybe a) (Maybe b)@ + -- hand, unwrapping on both sides yields @Coercible (Maybe a) (Maybe b)@ -- which we can then decompose to @Coercible a b@ and discharge with the -- given. <|> canonNewtypeLeft env a b @@ -601,7 +601,7 @@ throwError . errorMessage $ TypesDoNotUnify (rowFromList rl1) (rowFromList rl2) | otherwise = empty --- | Unwraping a newtype can fails in two ways: +-- | Unwrapping a newtype can fails in two ways: data UnwrapNewtypeError = CannotUnwrapInfiniteNewtypeChain -- ^ The newtype might wrap an infinite newtype chain. We may think that this @@ -620,7 +620,7 @@ -- -- yield a wanted @Coercible (N a) (N b)@ that we can decompose to -- @Coercible a b@ then discharge with the given if the newtype - -- unwraping rules do not apply. + -- unwrapping rules do not apply. | CannotUnwrapConstructor -- ^ The constructor may not be in scope or may not belong to a newtype. @@ -709,7 +709,7 @@ _ -> False -- | Constraints of the form @Coercible (N a_0 .. a_n) b@ yield a constraint --- @Coercible a b@ if unwraping the newtype yields @a@. +-- @Coercible a b@ if unwrapping the newtype yields @a@. canonNewtypeLeft :: MonadState CheckState m => MonadWriter [ErrorMessageHint] m @@ -724,7 +724,7 @@ Right a' -> pure . Canonicalized $ S.singleton (a', b) -- | Constraints of the form @Coercible a (N b_0 .. b_n)@ yield a constraint --- @Coercible a b@ if unwraping the newtype yields @b@. +-- @Coercible a b@ if unwrapping the newtype yields @b@. canonNewtypeRight :: MonadState CheckState m => MonadWriter [ErrorMessageHint] m @@ -779,7 +779,6 @@ -- @D@ is not a newtype, yield constraints on their arguments. canonDecomposition :: MonadError MultipleErrors m - => MonadState CheckState m => Environment -> SourceType -> SourceType @@ -797,7 +796,6 @@ -- newtypes, are insoluble. canonDecompositionFailure :: MonadError MultipleErrors m - => MonadState CheckState m => Environment -> SourceType -> SourceType @@ -829,7 +827,7 @@ -- Decomposing a given @Coercible (Const a a) (Const a b)@ constraint to -- @Coercible a b@ when @MkConst@ is out of scope would let us coerce arbitrary -- types in modules where @MkConst@ is imported, because the given is easily --- satisfied with the newtype unwraping rules. +-- satisfied with the newtype unwrapping rules. -- -- Moreover we do not decompose wanted constraints if they could be discharged -- by a given constraint. @@ -847,7 +845,6 @@ -- to discharge it with the given. canonNewtypeDecomposition :: MonadError MultipleErrors m - => MonadState CheckState m => Environment -> Maybe [(SourceType, SourceType, SourceType)] -> SourceType diff --git a/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs b/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs --- a/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/IntCompare.hs @@ -46,18 +46,18 @@ solveRelation :: forall a. Ord a => Context a -> a -> a -> Maybe PSOrdering solveRelation context lhs rhs = if lhs == rhs then - pure P.orderingEQ + pure P.EQ else do let (graph, search) = inequalities lhs' <- search lhs rhs' <- search rhs case (G.path graph lhs' rhs', G.path graph rhs' lhs') of (True, True) -> - pure P.orderingEQ + pure P.EQ (True, False) -> - pure P.orderingLT + pure P.LT (False, True) -> - pure P.orderingGT + pure P.GT _ -> Nothing where @@ -79,9 +79,9 @@ mkRelation :: P.Type a -> P.Type a -> P.Type a -> Maybe (Relation (P.Type a)) mkRelation lhs rhs rel = case rel of P.TypeConstructor _ ordering - | ordering == P.orderingEQ -> pure $ Equal lhs rhs - | ordering == P.orderingLT -> pure $ LessThan lhs rhs - | ordering == P.orderingGT -> pure $ LessThan rhs lhs + | ordering == P.EQ -> pure $ Equal lhs rhs + | ordering == P.LT -> pure $ LessThan lhs rhs + | ordering == P.GT -> pure $ LessThan rhs lhs _ -> Nothing diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -910,7 +910,7 @@ checkQuantification finalTy checkValidKind finalTy where - -- When expanding type synoyms and generalizing, we need to generate more + -- When expanding type synonyms and generalizing, we need to generate more -- unique names so that they don't clash or shadow other names, or can -- be referenced (easily). freshVar arg = (arg <>) . T.pack . show <$> fresh diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -365,7 +365,7 @@ "ParensInType" -> do b <- contents ParensInType a <$> go b - -- Backwards compatability for kinds + -- Backwards compatibility for kinds "KUnknown" -> TUnknown a <$> contents "Row" -> diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ # Please update Haskell image versions under .github/workflows/ci.yml together to use the same GHC version # (or the CI build will fail) -resolver: nightly-2022-06-09 +resolver: nightly-2022-11-12 pvp-bounds: both packages: - '.' diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -6,13 +6,14 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Filter.Declaration as D import Language.PureScript.Ide.Types +import Language.PureScript.Ide.Imports import Language.PureScript.Ide.Test as T import qualified Language.PureScript as P import Test.Hspec type Module = (P.ModuleName, [IdeDeclarationAnn]) -moduleA, moduleB, moduleC, moduleD, moduleE, moduleF, moduleG, moduleH, moduleI :: Module +moduleA, moduleB, moduleC, moduleD, moduleE, moduleF, moduleG, moduleH, moduleI, moduleDCtors :: Module moduleA = (P.moduleNameFromString "Module.A", [T.ideValue "function1" Nothing]) moduleB = (P.moduleNameFromString "Module.B", [T.ideValue "data1" Nothing]) moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing []]) @@ -22,10 +23,14 @@ moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindType []]) moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified P.ByNullSourcePos (Left "")) 0 Nothing Nothing]) moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified P.ByNullSourcePos "") 0 Nothing Nothing]) +moduleDCtors = (P.moduleNameFromString "Module.WithDC", [T.ideType "Foo" Nothing [(P.ProperName "A", P.tyString), (P.ProperName "B", P.tyString)] ]) modules :: ModuleMap [IdeDeclarationAnn] modules = Map.fromList [moduleA, moduleB] +allModules :: ModuleMap [IdeDeclarationAnn] +allModules = Map.fromList [moduleA, moduleB,moduleC,moduleD,moduleE,moduleF,moduleG,moduleH,moduleI,moduleDCtors] + runEq :: Text -> [Module] runEq s = Map.toList (applyFilters [exactFilter s] modules) @@ -41,6 +46,20 @@ runDeclaration :: [D.DeclarationType] -> [Module] -> [Module] runDeclaration decls = Map.toList . applyFilters [declarationTypeFilter (Set.fromList decls)] . Map.fromList +runDependency :: [Text] -> [Module] +runDependency = runDependency' "Whatever" + +runDependency' :: Text -> [Text] -> [Module] +runDependency' currentModuleName imports = Map.toList $ applyFilters [dependencyFilter Nothing (P.ModuleName currentModuleName) (testParseImports currentModuleName imports)] allModules + +runDependencyQualified :: Text -> [Text] -> [Module] +runDependencyQualified qualifier imports = Map.toList $ applyFilters [dependencyFilter (Just $ P.ModuleName qualifier) (P.ModuleName "Whatever") (testParseImports "Whatever" imports)] allModules + +testParseImports :: Text -> [Text] -> [Import] +testParseImports currentModuleName imports = either (const []) (\(_, _, x, _) -> x) $ sliceImportSection moduleLines + where + moduleLines = "module " <> currentModuleName <> " where" : (imports <> [ "", "blah = 42" ]) + spec :: Spec spec = do describe "equality Filter" $ do @@ -130,3 +149,45 @@ it "extracts modules by filtering `value`, and `valueoperator` declarations" $ runDeclaration [D.Value, D.ValueOperator] [moduleA, moduleB, moduleD, moduleG, moduleE, moduleH] `shouldBe` [moduleA, moduleB, moduleH] + describe "dependencyFilter" $ do + describe "import types" $ do + it "filters by implicit imports" $ do + runDependency ["import Module.A", "import Module.C"] `shouldBe` [moduleA, moduleC] + it "filters by matching explicit value import" $ do + runDependency ["import Module.A (function1)"] `shouldBe` [moduleA] + it "filters by matching explicit value import from correct module" $ do + runDependency ["import Module.B (function1)"] `shouldBe` [] + it "filters not matching explicit value import" $ do + runDependency ["import Module.A (function2)"] `shouldBe` [] + it "filters out names in hiding import" $ do + runDependency ["import Module.A hiding (function1)"] `shouldBe` [] + it "doesn't filter out not matching names in hiding import" $ do + runDependency ["import Module.A hiding (nonsense)"] `shouldBe` [moduleA] + it "filters by containing module" $ do + runDependency' "Module.A" ["import Module.Blah"] `shouldBe` [moduleA] + describe "declaration types" $ do + it "matches type" $ do + runDependency ["import Module.C (List)"] `shouldBe` [moduleC] + it "includes data constructor with (..)" $ do + runDependency ["import Module.F (TypeA(..))"] `shouldBe` [moduleF] + it "includes data constructor explicitly listed" $ do + runDependency ["import Module.F (TypeA(DtorA))"] `shouldBe` [moduleF] + it "does not include data constructor not explicitly listed" $ do + runDependency ["import Module.F (TypeA(BogusOtherConstructor))"] `shouldBe` [] + it "does not include data constructor when only the type is imported" $ do + runDependency ["import Module.F (TypeA)"] `shouldBe` [] + it "includes synonym" $ do + runDependency ["import Module.E (SFType)"] `shouldBe` [moduleE] + it "includes typeclass" $ do + runDependency ["import Module.G (class MyClass)"] `shouldBe` [moduleG] + it "includes value op" $ do + runDependency ["import Module.H ((<$>))"] `shouldBe` [moduleH] + it "includes type op" $ do + runDependency ["import Module.I (type (~>))"] `shouldBe` [moduleI] + describe "qualifiers" $ do + it "includes single qualified import and not unqualified things" $ do + runDependencyQualified "AA" [ "import Module.A as AA", "import Module.C"] `shouldBe` [moduleA] + it "includes multiple qualified imports" $ do + runDependencyQualified "Combined.Thing" [ "import Module.A as Combined.Thing", "import Module.C as Combined.Thing", "import Module.F"] `shouldBe` [moduleA, moduleC] + it "doesn't include qualified import when qualifier not specified" $ do + runDependency [ "import Module.AA as A"] `shouldBe` [] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -8,6 +8,7 @@ import Language.PureScript.Ide.Command as Command import Language.PureScript.Ide.Error import Language.PureScript.Ide.Imports +import Language.PureScript.Ide.Imports.Actions import Language.PureScript.Ide.Filter (moduleFilter) import qualified Language.PureScript.Ide.Test as Test import Language.PureScript.Ide.Types diff --git a/tests/TestMake.hs b/tests/TestMake.hs --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -166,7 +166,7 @@ moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" optsWithDocs = P.defaultOptions { P.optionsCodegenTargets = Set.fromList [P.JS, P.Docs] } go opts = compileWithOptions opts [modulePath] >>= assertSuccess - oneSecond = 10^(6::Int) -- microseconds. + oneSecond = 10 ^ (6::Int) -- microseconds. writeFileWithTimestamp modulePath timestampA moduleContent1 go optsWithDocs `shouldReturn` moduleNames ["Module"] @@ -184,7 +184,7 @@ moduleContent2 = moduleContent1 <> "\ny :: Int\ny = 1" optsCorefnOnly = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.CoreFn } go opts = compileWithOptions opts [modulePath] >>= assertSuccess - oneSecond = 10^(6::Int) -- microseconds. + oneSecond = 10 ^ (6::Int) -- microseconds. writeFileWithTimestamp modulePath timestampA moduleContent1 go optsCorefnOnly `shouldReturn` moduleNames ["Module"] diff --git a/tests/purs/failing/2567.out b/tests/purs/failing/2567.out --- a/tests/purs/failing/2567.out +++ b/tests/purs/failing/2567.out @@ -2,7 +2,7 @@ in module Main at tests/purs/failing/2567.purs:7:8 - 7:67 (line 7, column 8 - line 7, column 67) - A custom type error occurred while solving type class constraints: + Custom error: This constraint should be checked diff --git a/tests/purs/failing/BifunctorInstance1.out b/tests/purs/failing/BifunctorInstance1.out new file mode 100644 --- /dev/null +++ b/tests/purs/failing/BifunctorInstance1.out @@ -0,0 +1,16 @@ +Error found: +in module BifunctorInstance1 +at tests/purs/failing/BifunctorInstance1.purs:10:1 - 10:31 (line 10, column 1 - line 10, column 31) + + One or more type variables are in positions that prevent Bifunctor from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, that their variance matches the variance of Bifunctor, and that those type constructors themselves have instances of Data.Functor.Functor, Data.Bifunctor.Bifunctor, Data.Functor.Contravariant.Contravariant, or Data.Profunctor.Profunctor. + + tests/purs/failing/BifunctorInstance1.purs: +  8  +  9 data Test a b = Test (Tuple (Predicate a) (Predicate b)) (Tuple a b) +  10 derive instance Bifunctor Test + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/BifunctorInstance1.purs b/tests/purs/failing/BifunctorInstance1.purs new file mode 100644 --- /dev/null +++ b/tests/purs/failing/BifunctorInstance1.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module BifunctorInstance1 where + +import Prelude +import Data.Bifunctor (class Bifunctor) +import Data.Predicate (Predicate) +import Data.Tuple (Tuple) + +data Test a b = Test (Tuple (Predicate a) (Predicate b)) (Tuple a b) +derive instance Bifunctor Test diff --git a/tests/purs/failing/ContravariantInstance1.out b/tests/purs/failing/ContravariantInstance1.out new file mode 100644 --- /dev/null +++ b/tests/purs/failing/ContravariantInstance1.out @@ -0,0 +1,16 @@ +Error found: +in module ContravariantInstance1 +at tests/purs/failing/ContravariantInstance1.purs:9:1 - 9:35 (line 9, column 1 - line 9, column 35) + + One or more type variables are in positions that prevent Contravariant from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, that their variance matches the variance of Contravariant, and that those type constructors themselves have instances of Data.Functor.Functor, Data.Bifunctor.Bifunctor, Data.Functor.Contravariant.Contravariant, or Data.Profunctor.Profunctor. + + tests/purs/failing/ContravariantInstance1.purs: +  6  +  7 newtype Test a = Test (Predicate (Predicate a)) +  8  + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/ContravariantInstance1.purs b/tests/purs/failing/ContravariantInstance1.purs new file mode 100644 --- /dev/null +++ b/tests/purs/failing/ContravariantInstance1.purs @@ -0,0 +1,9 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module ContravariantInstance1 where + +import Data.Functor.Contravariant (class Contravariant) +import Data.Predicate (Predicate) + +newtype Test a = Test (Predicate (Predicate a)) + +derive instance Contravariant Test diff --git a/tests/purs/failing/DuplicateDeclarationsInLet.out b/tests/purs/failing/DuplicateDeclarationsInLet.out --- a/tests/purs/failing/DuplicateDeclarationsInLet.out +++ b/tests/purs/failing/DuplicateDeclarationsInLet.out @@ -1,8 +1,8 @@ Error found: in module Main -at tests/purs/failing/DuplicateDeclarationsInLet.purs:6:7 - 6:8 (line 6, column 7 - line 6, column 8) +at tests/purs/failing/DuplicateDeclarationsInLet.purs:9:3 - 9:14 (line 9, column 3 - line 9, column 14) - The same name was used more than once in a let binding. + The name a was defined multiple times in a binding group See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, diff --git a/tests/purs/failing/DuplicateDeclarationsInLet.purs b/tests/purs/failing/DuplicateDeclarationsInLet.purs --- a/tests/purs/failing/DuplicateDeclarationsInLet.purs +++ b/tests/purs/failing/DuplicateDeclarationsInLet.purs @@ -1,8 +1,6 @@ -- @shouldFailWith OverlappingNamesInLet module Main where -import Prelude - foo = a where a :: Number diff --git a/tests/purs/failing/DuplicateDeclarationsInLet2.out b/tests/purs/failing/DuplicateDeclarationsInLet2.out new file mode 100644 --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet2.out @@ -0,0 +1,10 @@ +Error found: +in module Main +at tests/purs/failing/DuplicateDeclarationsInLet2.purs:10:3 - 10:24 (line 10, column 3 - line 10, column 24) + + The name interrupted was defined multiple times in a binding group + + +See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateDeclarationsInLet2.purs b/tests/purs/failing/DuplicateDeclarationsInLet2.purs new file mode 100644 --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet2.purs @@ -0,0 +1,10 @@ +-- @shouldFailWith OverlappingNamesInLet +module Main where + +foo = interrupted + where + interrupted true = 1 + + interrupter = 2 + + interrupted false = 3 diff --git a/tests/purs/failing/DuplicateDeclarationsInLet3.out b/tests/purs/failing/DuplicateDeclarationsInLet3.out new file mode 100644 --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet3.out @@ -0,0 +1,22 @@ +Error 1 of 2: + + in module Main + at tests/purs/failing/DuplicateDeclarationsInLet3.purs:9:3 - 9:11 (line 9, column 3 - line 9, column 11) + + The name a was defined multiple times in a binding group + + + See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, + or to contribute content related to this error. + +Error 2 of 2: + + in module Main + at tests/purs/failing/DuplicateDeclarationsInLet3.purs:16:3 - 16:24 (line 16, column 3 - line 16, column 24) + + The name interrupted was defined multiple times in a binding group + + + See https://github.com/purescript/documentation/blob/master/errors/OverlappingNamesInLet.md for more information, + or to contribute content related to this error. + diff --git a/tests/purs/failing/DuplicateDeclarationsInLet3.purs b/tests/purs/failing/DuplicateDeclarationsInLet3.purs new file mode 100644 --- /dev/null +++ b/tests/purs/failing/DuplicateDeclarationsInLet3.purs @@ -0,0 +1,16 @@ +-- @shouldFailWith OverlappingNamesInLet +-- @shouldFailWith OverlappingNamesInLet +module Main where + +-- Should see separate errors for `a` and `interrupted` +foo = interrupter + a + where + a = 0 + a :: Int + a = 0 + + interrupted true = 1 + + interrupter = 2 + + interrupted false = 3 diff --git a/tests/purs/failing/FoldableInstance10.out b/tests/purs/failing/FoldableInstance10.out --- a/tests/purs/failing/FoldableInstance10.out +++ b/tests/purs/failing/FoldableInstance10.out @@ -3,7 +3,7 @@ at tests/purs/failing/FoldableInstance10.purs:11:1 - 11:30 (line 11, column 1 - line 11, column 30) One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. tests/purs/failing/FoldableInstance10.purs:  9  diff --git a/tests/purs/failing/FoldableInstance4.out b/tests/purs/failing/FoldableInstance4.out --- a/tests/purs/failing/FoldableInstance4.out +++ b/tests/purs/failing/FoldableInstance4.out @@ -2,22 +2,15 @@ in module FoldableInstance4 at tests/purs/failing/FoldableInstance4.purs:8:1 - 8:27 (line 8, column 1 - line 8, column 27) - No type class instance was found for -   -  Data.Foldable.Foldable (Function t3) -   - The instance head contains unknown type variables. Consider adding a type annotation. + One or more type variables are in positions that prevent Foldable from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. -while applying a function foldl - of type Foldable t0 => (t1 -> t2 -> t1) -> t1 -> t0 t2 -> t1 - to argument $f1 -while inferring the type of foldl $f1 + tests/purs/failing/FoldableInstance4.purs: +  6  +  7 data T a = T (forall t. Show t => t -> a) +  8 derive instance Foldable T -where t0 is an unknown type - t2 is an unknown type - t1 is an unknown type - t3 is an unknown type -See https://github.com/purescript/documentation/blob/master/errors/NoInstanceFound.md for more information, +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, or to contribute content related to this error. diff --git a/tests/purs/failing/FoldableInstance4.purs b/tests/purs/failing/FoldableInstance4.purs --- a/tests/purs/failing/FoldableInstance4.purs +++ b/tests/purs/failing/FoldableInstance4.purs @@ -1,4 +1,4 @@ --- @shouldFailWith NoInstanceFound +-- @shouldFailWith CannotDeriveInvalidConstructorArg module FoldableInstance4 where import Prelude diff --git a/tests/purs/failing/FoldableInstance5.out b/tests/purs/failing/FoldableInstance5.out deleted file mode 100644 --- a/tests/purs/failing/FoldableInstance5.out +++ /dev/null @@ -1,16 +0,0 @@ -Error found: -in module FoldableInstance5 -at tests/purs/failing/FoldableInstance5.purs:9:1 - 9:30 (line 9, column 1 - line 9, column 30) - - One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - - tests/purs/failing/FoldableInstance5.purs: -  7  -  8 data Test a = Test (Tuple a Int) -  9 derive instance Foldable Test - - -See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/FoldableInstance5.purs b/tests/purs/failing/FoldableInstance5.purs deleted file mode 100644 --- a/tests/purs/failing/FoldableInstance5.purs +++ /dev/null @@ -1,9 +0,0 @@ --- @shouldFailWith CannotDeriveInvalidConstructorArg -module FoldableInstance5 where - -import Prelude -import Data.Foldable (class Foldable) -import Data.Tuple (Tuple(..)) - -data Test a = Test (Tuple a Int) -derive instance Foldable Test diff --git a/tests/purs/failing/FoldableInstance6.out b/tests/purs/failing/FoldableInstance6.out --- a/tests/purs/failing/FoldableInstance6.out +++ b/tests/purs/failing/FoldableInstance6.out @@ -3,7 +3,7 @@ at tests/purs/failing/FoldableInstance6.purs:8:1 - 8:30 (line 8, column 1 - line 8, column 30) One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. tests/purs/failing/FoldableInstance6.purs:  6  diff --git a/tests/purs/failing/FoldableInstance7.out b/tests/purs/failing/FoldableInstance7.out deleted file mode 100644 --- a/tests/purs/failing/FoldableInstance7.out +++ /dev/null @@ -1,16 +0,0 @@ -Error found: -in module FoldableInstance6 -at tests/purs/failing/FoldableInstance7.purs:9:1 - 9:30 (line 9, column 1 - line 9, column 30) - - One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. - - tests/purs/failing/FoldableInstance7.purs: -  7  -  8 data Test a = Test (Tuple a a) -  9 derive instance Foldable Test - - -See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, -or to contribute content related to this error. - diff --git a/tests/purs/failing/FoldableInstance7.purs b/tests/purs/failing/FoldableInstance7.purs deleted file mode 100644 --- a/tests/purs/failing/FoldableInstance7.purs +++ /dev/null @@ -1,9 +0,0 @@ --- @shouldFailWith CannotDeriveInvalidConstructorArg -module FoldableInstance6 where - -import Prelude -import Data.Tuple (Tuple(..)) -import Data.Foldable (class Foldable) - -data Test a = Test (Tuple a a) -derive instance Foldable Test diff --git a/tests/purs/failing/FoldableInstance8.out b/tests/purs/failing/FoldableInstance8.out --- a/tests/purs/failing/FoldableInstance8.out +++ b/tests/purs/failing/FoldableInstance8.out @@ -3,11 +3,11 @@ at tests/purs/failing/FoldableInstance8.purs:8:1 - 8:34 (line 8, column 1 - line 8, column 34) One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. tests/purs/failing/FoldableInstance8.purs:  6  -  7 data Test f a = Test (f a a) +  7 data Test f a = Test (f a a)  8 derive instance Foldable (Test f) diff --git a/tests/purs/failing/FoldableInstance9.out b/tests/purs/failing/FoldableInstance9.out --- a/tests/purs/failing/FoldableInstance9.out +++ b/tests/purs/failing/FoldableInstance9.out @@ -3,13 +3,13 @@ at tests/purs/failing/FoldableInstance9.purs:53:1 - 53:38 (line 53, column 1 - line 53, column 38) One or more type variables are in positions that prevent Foldable from being derived. - To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Foldable. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, and that those type constructors themselves have instances of Data.Foldable.Foldable or Data.Bifoldable.Bifoldable. tests/purs/failing/FoldableInstance9.purs:  15 data Test f g h a -  16  = Test1 (f a a a) (f Int a a) (f a a Int) (f Int a Int) (f Int Int Int) -  17  | Test2 { all :: f a a a -  18  , rights :: f Int a a +  16  = Test1 (f a a a) (f Int a a) (f a a Int) (f Int a Int) (f Int Int Int) +  17  | Test2 { all :: f a a a +  18  , rights :: f Int a a  19  , lefts :: f a a Int  20  , middle :: f Int a Int  21  , none :: f Int Int Int @@ -20,7 +20,9 @@  26  , lefts :: f a a Int  27  , middle :: f Int a Int  28  , none :: f Int Int Int -  ... +  29  } +  30  a) +  31  | Test4 (h  32  { nested1 ::  33  { all :: f a a a  34  , rights :: f Int a a @@ -37,10 +39,10 @@  46  }  47  a  48  } -  49  a) +  49  a)  50  | Test5 (Rec f a) -  51  | Test6 (g (Rec f a) a) -  52  | Test7 (h { nested1 :: Rec f a, nested2 :: g (Rec f a) a } a) +  51  | Test6 (g (Rec f a) a) +  52  | Test7 (h { nested1 :: Rec f a, nested2 :: g (Rec f a) a } a)  53 derive instance Foldable (Test f g h) diff --git a/tests/purs/failing/FunctorInstance1.out b/tests/purs/failing/FunctorInstance1.out new file mode 100644 --- /dev/null +++ b/tests/purs/failing/FunctorInstance1.out @@ -0,0 +1,16 @@ +Error found: +in module FunctorInstance1 +at tests/purs/failing/FunctorInstance1.purs:8:1 - 8:29 (line 8, column 1 - line 8, column 29) + + One or more type variables are in positions that prevent Functor from being derived. + To derive this class, make sure that these variables are only used as the final arguments to type constructors, that their variance matches the variance of Functor, and that those type constructors themselves have instances of Data.Functor.Functor, Data.Bifunctor.Bifunctor, Data.Functor.Contravariant.Contravariant, or Data.Profunctor.Profunctor. + + tests/purs/failing/FunctorInstance1.purs: +  6  +  7 data Test a = Test (Predicate a) +  8 derive instance Functor Test + + +See https://github.com/purescript/documentation/blob/master/errors/CannotDeriveInvalidConstructorArg.md for more information, +or to contribute content related to this error. + diff --git a/tests/purs/failing/FunctorInstance1.purs b/tests/purs/failing/FunctorInstance1.purs new file mode 100644 --- /dev/null +++ b/tests/purs/failing/FunctorInstance1.purs @@ -0,0 +1,8 @@ +-- @shouldFailWith CannotDeriveInvalidConstructorArg +module FunctorInstance1 where + +import Prelude +import Data.Predicate (Predicate) + +data Test a = Test (Predicate a) +derive instance Functor Test diff --git a/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out b/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out --- a/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out +++ b/tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.out @@ -2,7 +2,7 @@ in module Main at tests/purs/failing/ProgrammablePolykindedTypeErrorsTypeString.purs:23:7 - 23:17 (line 23, column 7 - line 23, column 17) - A custom type error occurred while solving type class constraints: + Custom error: Don't want to show Just @Type String because. diff --git a/tests/purs/failing/ProgrammableTypeErrors.out b/tests/purs/failing/ProgrammableTypeErrors.out --- a/tests/purs/failing/ProgrammableTypeErrors.out +++ b/tests/purs/failing/ProgrammableTypeErrors.out @@ -2,7 +2,7 @@ in module Main at tests/purs/failing/ProgrammableTypeErrors.purs:17:13 - 17:27 (line 17, column 13 - line 17, column 27) - A custom type error occurred while solving type class constraints: + Custom error: Cannot show functions diff --git a/tests/purs/failing/ProgrammableTypeErrorsTypeString.out b/tests/purs/failing/ProgrammableTypeErrorsTypeString.out --- a/tests/purs/failing/ProgrammableTypeErrorsTypeString.out +++ b/tests/purs/failing/ProgrammableTypeErrorsTypeString.out @@ -2,7 +2,7 @@ in module Main at tests/purs/failing/ProgrammableTypeErrorsTypeString.purs:24:9 - 24:24 (line 24, column 9 - line 24, column 24) - A custom type error occurred while solving type class constraints: + Custom error: Don't want to show MyType Int because. diff --git a/tests/purs/passing/DerivingBifunctor.purs b/tests/purs/passing/DerivingBifunctor.purs new file mode 100644 --- /dev/null +++ b/tests/purs/passing/DerivingBifunctor.purs @@ -0,0 +1,26 @@ +module Main where + +import Prelude + +import Data.Bifoldable (class Bifoldable) +import Data.Bifunctor (class Bifunctor) +import Data.Bitraversable (class Bitraversable) +import Data.Predicate (Predicate) +import Data.Tuple (Tuple) +import Effect.Console (log) + +data Test f a b + = Test0 + | Test1 (Array a) b + | Test2 Int (forall a. Array a -> Array a) + | Test3 Int (f a b) (f a Int) (f Int b) + | Test4 (Array (Tuple a Int)) (Tuple b Int) + | Test5 { nested :: Array { x :: f { a :: a } { b :: b } } } +derive instance Bifunctor f => Bifunctor (Test f) +derive instance Bifoldable f => Bifoldable (Test f) +derive instance Bitraversable f => Bitraversable (Test f) + +data FromProAndContra a b = FromProAndContra (Predicate (a -> Int)) (Predicate b -> Int) +derive instance Bifunctor FromProAndContra + +main = log "Done" diff --git a/tests/purs/passing/DerivingContravariant.purs b/tests/purs/passing/DerivingContravariant.purs new file mode 100644 --- /dev/null +++ b/tests/purs/passing/DerivingContravariant.purs @@ -0,0 +1,20 @@ +module Main where + +import Prelude + +import Data.Functor.Contravariant (class Contravariant) +import Data.Predicate (Predicate) +import Data.Tuple (Tuple) +import Effect.Console (log) + +data Test f a + = Test0 + | Test1 (Predicate a) + | Test2 (Predicate (Predicate (Predicate a))) + | Test3 Int (forall a. Array a -> Array a) + | Test4 Int (f a) + | Test5 (Array (a -> Int)) (Tuple (Predicate a) Int) + | Test6 { nested :: Array { x :: f { a :: a } } } +derive instance Contravariant f => Contravariant (Test f) + +main = log "Done" diff --git a/tests/purs/passing/DerivingFunctorFromBi.purs b/tests/purs/passing/DerivingFunctorFromBi.purs new file mode 100644 --- /dev/null +++ b/tests/purs/passing/DerivingFunctorFromBi.purs @@ -0,0 +1,18 @@ +module Main where + +import Prelude + +import Data.Foldable (class Foldable) +import Data.Traversable (class Traversable) +import Data.Tuple (Tuple) +import Effect.Console (log) + +data Test a + = Test1 (Tuple a Int) + | Test2 (Tuple (Array a) a) + | Test3 { x :: Tuple { a :: a } Int, y :: Tuple { a :: Array a } { a :: a } } +derive instance Functor Test +derive instance Foldable Test +derive instance Traversable Test + +main = log "Done" diff --git a/tests/purs/passing/DerivingFunctorFromContra.purs b/tests/purs/passing/DerivingFunctorFromContra.purs new file mode 100644 --- /dev/null +++ b/tests/purs/passing/DerivingFunctorFromContra.purs @@ -0,0 +1,13 @@ +module Main where + +import Prelude + +import Data.Predicate (Predicate) +import Effect.Console (log) + +data Test a + = Test1 (Predicate (Predicate a)) + | Test2 { x :: Predicate { y :: Predicate a } } +derive instance Functor Test + +main = log "Done" diff --git a/tests/purs/passing/DerivingFunctorFromPro.purs b/tests/purs/passing/DerivingFunctorFromPro.purs new file mode 100644 --- /dev/null +++ b/tests/purs/passing/DerivingFunctorFromPro.purs @@ -0,0 +1,16 @@ +module Main where + +-- Note that Data.Profunctor is not in the dependencies of any types imported +-- here. The package that contains that module must be a dependency of the test +-- project. + +import Prelude + +import Effect.Console (log) + +data Test a + = Test1 ((Array a -> Int) -> Int) + | Test2 { f :: ({ a :: a } -> Int) -> Int } +derive instance Functor Test + +main = log "Done" diff --git a/tests/purs/passing/DerivingFunctorPrefersSimplerClasses.purs b/tests/purs/passing/DerivingFunctorPrefersSimplerClasses.purs new file mode 100644 --- /dev/null +++ b/tests/purs/passing/DerivingFunctorPrefersSimplerClasses.purs @@ -0,0 +1,46 @@ +module Main where + +import Prelude + +import Data.Bifunctor (class Bifunctor) +import Data.Profunctor (class Profunctor) +import Effect (Effect) +import Effect.Console (log) +import Test.Assert (assert') + +newtype MonoAndBi a b = MonoAndBi (Effect Unit) +derive instance Functor (MonoAndBi a) +instance Bifunctor MonoAndBi where + bimap _ _ _ = MonoAndBi (assert' "Bifunctor instance was used but the Functor instance was expected" false) + +newtype Test1 a = Test1 (MonoAndBi Int a) +derive instance Functor Test1 + +data ExclusivelyBi a b +derive instance Bifunctor ExclusivelyBi + +newtype Test2 a = Test2 (ExclusivelyBi Int a) +derive instance Functor Test2 + +newtype MonoAndPro a b = MonoAndPro (Effect Unit) +derive instance Functor (MonoAndPro a) +instance Profunctor MonoAndPro where + dimap _ _ _ = MonoAndPro (assert' "Profunctor instance was used but the Functor instance was expected" false) + +newtype Test3 a = Test3 (MonoAndPro Int a) +derive instance Functor Test3 + +data ExclusivelyPro a b +derive instance Profunctor ExclusivelyPro + +newtype Test4 a = Test4 (ExclusivelyPro Int a) +derive instance Functor Test4 + +main = do + let t = Test1 (MonoAndBi (pure unit)) + let Test1 (MonoAndBi result1) = map identity t + result1 + let t = Test3 (MonoAndPro (pure unit)) + let Test3 (MonoAndPro result3) = map identity t + result3 + log "Done" diff --git a/tests/purs/passing/DerivingProfunctor.purs b/tests/purs/passing/DerivingProfunctor.purs new file mode 100644 --- /dev/null +++ b/tests/purs/passing/DerivingProfunctor.purs @@ -0,0 +1,19 @@ +module Main where + +import Prelude + +import Data.Predicate (Predicate) +import Data.Profunctor (class Profunctor) +import Data.Tuple (Tuple) +import Effect.Console (log) + +data Test f a b + = Test0 + | Test1 (Predicate a) b + | Test2 Int (forall a. Array a -> Array a) + | Test3 Int (f a b) (f a Int) (f Int b) + | Test4 (Array (a -> Int)) (Tuple b Int) + | Test5 { nested :: Array { x :: f { a :: a } { b :: b } } } +derive instance Profunctor f => Profunctor (Test f) + +main = log "Done"