summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorhdgarrood <>2020-01-18 16:10:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-01-18 16:10:00 (GMT)
commit27a66e51ef65d927736c86e64f820e93fd6b3c65 (patch)
treef2308d44b832e7b32d81854ff3567aa5ccb3679d
parent8be6c7045bf80d275a59ee3bc1d17c6cd07f95e4 (diff)
version 0.13.60.13.6
-rw-r--r--LICENSE192
-rw-r--r--purescript.cabal3
-rw-r--r--src/Language/PureScript/AST/Declarations.hs2
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs4
-rw-r--r--src/Language/PureScript/Docs/Convert.hs12
-rw-r--r--src/Language/PureScript/Errors.hs12
-rw-r--r--src/Language/PureScript/Ide.hs3
-rw-r--r--src/Language/PureScript/Ide/Imports.hs2
-rw-r--r--src/Language/PureScript/Ide/Matcher.hs2
-rw-r--r--src/Language/PureScript/Interactive/Directive.hs2
-rw-r--r--src/Language/PureScript/Interactive/Types.hs11
-rw-r--r--src/Language/PureScript/Kinds.hs2
-rw-r--r--src/Language/PureScript/Make.hs34
-rw-r--r--src/Language/PureScript/Make/Actions.hs11
-rw-r--r--src/Language/PureScript/Make/BuildPlan.hs7
-rw-r--r--src/Language/PureScript/PSString.hs70
-rw-r--r--src/Language/PureScript/Sugar.hs7
-rw-r--r--src/Language/PureScript/Sugar/AdoNotation.hs49
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs19
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs24
-rw-r--r--src/Language/PureScript/Sugar/Names.hs118
-rw-r--r--src/Language/PureScript/Sugar/Operators/Common.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs63
-rw-r--r--src/Language/PureScript/Types.hs2
-rw-r--r--tests/purs/passing/3238.purs14
-rw-r--r--tests/purs/passing/Guards.purs6
-rw-r--r--tests/purs/warning/ScopeShadowing.purs2
28 files changed, 383 insertions, 294 deletions
diff --git a/LICENSE b/LICENSE
index 362b1f1..52d6ce7 100644
--- a/LICENSE
+++ b/LICENSE
@@ -47,6 +47,7 @@ PureScript uses the following Haskell library packages. Their license files foll
bytestring-builder
cabal-doctest
case-insensitive
+ cereal
cheapskate
clock
colour
@@ -71,7 +72,6 @@ PureScript uses the following Haskell library packages. Their license files foll
dlist
easy-file
edit-distance
- enclosed-exceptions
entropy
exceptions
fast-logger
@@ -83,7 +83,7 @@ PureScript uses the following Haskell library packages. Their license files foll
happy
hashable
haskeline
- hinotify
+ hfsevents
http-date
http-types
http2
@@ -129,7 +129,6 @@ PureScript uses the following Haskell library packages. Their license files foll
semialign
semigroupoids
semigroups
- shelly
simple-sendfile
sourcemap
split
@@ -138,8 +137,6 @@ PureScript uses the following Haskell library packages. Their license files foll
streaming-commons
stringsearch
syb
- system-fileio
- system-filepath
tagged
tagsoup
template-haskell
@@ -1295,6 +1292,39 @@ case-insensitive LICENSE file:
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+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
@@ -2021,29 +2051,6 @@ edit-distance LICENSE file:
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.
-enclosed-exceptions LICENSE file:
-
- Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-
- Permission is hereby granted, free of charge, to any person obtaining
- a copy of this software and associated documentation files (the
- "Software"), to deal in the Software without restriction, including
- without limitation the rights to use, copy, modify, merge, publish,
- distribute, sublicense, and/or sell copies of the Software, and to
- permit persons to whom the Software is furnished to do so, subject to
- the following conditions:
-
- The above copyright notice and this permission notice shall be
- included in all copies or substantial portions of the Software.
-
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
- LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
- WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
entropy LICENSE file:
Copyright (c) Thomas DuBuisson
@@ -2428,38 +2435,38 @@ haskeline LICENSE file:
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-hinotify LICENSE file:
+hfsevents LICENSE file:
- Copyright (c) Lennart Kolmodin
+ 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:
+ 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.
+ * 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.
+ * 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.
+ * 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 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.
+ 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-date LICENSE file:
@@ -3947,39 +3954,6 @@ semigroups LICENSE file:
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
-shelly LICENSE file:
-
- Copyright (c) 2017, Petr Rockai <me@mornfall.net>
-
- 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 Petr Rockai 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.
-
simple-sendfile LICENSE file:
Copyright (c) 2009, IIJ Innovation Institute Inc.
@@ -4290,56 +4264,6 @@ syb LICENSE file:
-----------------------------------------------------------------------------
-system-fileio LICENSE file:
-
- Copyright (c) 2011 John Millikin
-
- Permission is hereby granted, free of charge, to any person
- obtaining a copy of this software and associated documentation
- files (the "Software"), to deal in the Software without
- restriction, including without limitation the rights to use,
- copy, modify, merge, publish, distribute, sublicense, and/or sell
- copies of the Software, and to permit persons to whom the
- Software is furnished to do so, subject to the following
- conditions:
-
- The above copyright notice and this permission notice shall be
- included in all copies or substantial portions of the Software.
-
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
- OTHER DEALINGS IN THE SOFTWARE.
-
-system-filepath LICENSE file:
-
- Copyright (c) 2010 John Millikin
-
- Permission is hereby granted, free of charge, to any person
- obtaining a copy of this software and associated documentation
- files (the "Software"), to deal in the Software without
- restriction, including without limitation the rights to use,
- copy, modify, merge, publish, distribute, sublicense, and/or sell
- copies of the Software, and to permit persons to whom the
- Software is furnished to do so, subject to the following
- conditions:
-
- The above copyright notice and this permission notice shall be
- included in all copies or substantial portions of the Software.
-
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
- OTHER DEALINGS IN THE SOFTWARE.
-
tagged LICENSE file:
Copyright (c) 2009-2015 Edward Kmett
diff --git a/purescript.cabal b/purescript.cabal
index fb3dd50..0724a0b 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,6 +1,6 @@
cabal-version: 1.12
name: purescript
-version: 0.13.5
+version: 0.13.6
license: BSD3
license-file: LICENSE
copyright: (c) 2013-17 Phil Freeman, (c) 2014-19 Gary Burgess, (c) other contributors (see CONTRIBUTORS.md)
@@ -401,6 +401,7 @@ extra-source-files:
tests/purs/passing/3114/VendoredVariant.purs
tests/purs/passing/3125.purs
tests/purs/passing/3187-UnusedNameClash.purs
+ tests/purs/passing/3238.purs
tests/purs/passing/3388.purs
tests/purs/passing/3410.purs
tests/purs/passing/3481.purs
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index 557cb51..e4f6d0e 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -111,7 +111,7 @@ data SimpleErrorMessage
| ConstrainedTypeUnified SourceType SourceType
| OverlappingInstances (Qualified (ProperName 'ClassName)) [SourceType] [Qualified Ident]
| NoInstanceFound SourceConstraint
- | AmbiguousTypeVariables SourceType SourceConstraint
+ | AmbiguousTypeVariables SourceType [Int]
| UnknownClass (Qualified (ProperName 'ClassName))
| PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [SourceType]
| CannotDerive (Qualified (ProperName 'ClassName)) [SourceType]
diff --git a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
index 1a2cde1..c14988f 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/MagicDo.hs
@@ -48,6 +48,10 @@ magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
-- Desugar discard
convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 js)]) | isDiscard bind =
Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js )
+ -- Desugar bind to wildcard
+ convert (App _ (App _ bind [m]) [Function s1 Nothing [] (Block s2 js)])
+ | isBind bind =
+ Function s1 (Just fnName) [] $ Block s2 (App s2 m [] : map applyReturns js )
-- Desugar bind
convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 js)]) | isBind bind =
Function s1 (Just fnName) [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns js)
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index c2f8a75..a7af113 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -35,11 +35,12 @@ import qualified Language.PureScript.Types as P
convertModule ::
MonadError P.MultipleErrors m =>
[P.ExternsFile] ->
+ P.Env ->
P.Environment ->
P.Module ->
m Module
-convertModule externs checkEnv m =
- partiallyDesugar externs [m] >>= \case
+convertModule externs env checkEnv m =
+ partiallyDesugar externs env [m] >>= \case
[m'] -> pure (insertValueTypes checkEnv (convertSingleModule m'))
_ -> P.internalError "partiallyDesugar did not return a singleton"
@@ -88,9 +89,10 @@ runParser p =
partiallyDesugar ::
(MonadError P.MultipleErrors m) =>
[P.ExternsFile] ->
+ P.Env ->
[P.Module] ->
m [P.Module]
-partiallyDesugar externs = evalSupplyT 0 . desugar'
+partiallyDesugar externs env = evalSupplyT 0 . desugar'
where
desugar' =
traverse P.desugarDoModule
@@ -98,10 +100,8 @@ partiallyDesugar externs = evalSupplyT 0 . desugar'
>=> map P.desugarLetPatternModule
>>> traverse P.desugarCasesModule
>=> traverse P.desugarTypeDeclarationsModule
- >=> ignoreWarnings . P.desugarImports externs
+ >=> fmap fst . runWriterT . P.desugarImports env
>=> P.rebracketFiltered isInstanceDecl externs
- ignoreWarnings = fmap fst . runWriterT
-
isInstanceDecl (P.TypeInstanceDeclaration {}) = True
isInstanceDecl _ = False
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 1386ce6..19b2ab7 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -286,7 +286,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t
gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con
- gSimple (AmbiguousTypeVariables t con) = AmbiguousTypeVariables <$> f t <*> pure con
+ gSimple (AmbiguousTypeVariables t us) = AmbiguousTypeVariables <$> f t <*> pure us
gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
@@ -679,10 +679,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
where
go TUnknown{} = True
go _ = False
- renderSimpleErrorMessage (AmbiguousTypeVariables t _) =
+ renderSimpleErrorMessage (AmbiguousTypeVariables t us) =
paras [ line "The inferred type"
, markCodeBox $ indent $ typeAsBox prettyDepth t
- , line "has type variables which are not mentioned in the body of the type. Consider adding a type annotation."
+ , line "has type variables which are not determined by those mentioned in the body of the type:"
+ , indent $ Box.hsep 1 Box.left
+ [ Box.vcat Box.left
+ [ line $ markCode ("t" <> T.pack (show u)) <> " could not be determined"
+ | u <- us ]
+ ]
+ , line "Consider adding a type annotation."
]
renderSimpleErrorMessage (PossiblyInfiniteInstance nm ts) =
paras [ line "Type class instance for"
diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs
index 58aafac..8e6e722 100644
--- a/src/Language/PureScript/Ide.hs
+++ b/src/Language/PureScript/Ide.hs
@@ -51,7 +51,8 @@ handleCommand
-> m Success
handleCommand c = case c of
Load [] ->
- findAvailableExterns >>= loadModulesAsync
+ -- Clearing the State before populating it to avoid a space leak
+ resetIdeState *> findAvailableExterns >>= loadModulesAsync
Load modules ->
loadModulesAsync modules
LoadSync [] ->
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index 6af718b..46e55f4 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -303,7 +303,7 @@ addImportForIdentifier fp ident qual filters = do
-- 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 aswell as a type synonym.
+ -- a type as well as a type synonym.
ms@[Match (m1, d1), Match (m2, d2)] ->
if m1 /= m2
diff --git a/src/Language/PureScript/Ide/Matcher.hs b/src/Language/PureScript/Ide/Matcher.hs
index e5bf21e..1baf898 100644
--- a/src/Language/PureScript/Ide/Matcher.hs
+++ b/src/Language/PureScript/Ide/Matcher.hs
@@ -52,7 +52,7 @@ instance FromJSON (Matcher IdeDeclarationAnn) where
Just _ -> mzero
Nothing -> return mempty
--- | Matches any occurence of the search string with intersections
+-- | Matches any occurrence of the search string with intersections
--
-- The scoring measures how far the matches span the string where
-- closer is better.
diff --git a/src/Language/PureScript/Interactive/Directive.hs b/src/Language/PureScript/Interactive/Directive.hs
index 5538315..cee68ef 100644
--- a/src/Language/PureScript/Interactive/Directive.hs
+++ b/src/Language/PureScript/Interactive/Directive.hs
@@ -12,7 +12,7 @@ import Data.Tuple (swap)
import Language.PureScript.Interactive.Types
-- |
--- List of all avaliable directives.
+-- List of all available directives.
--
directives :: [Directive]
directives = map fst directiveStrings
diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs
index 84e926b..cb4693e 100644
--- a/src/Language/PureScript/Interactive/Types.hs
+++ b/src/Language/PureScript/Interactive/Types.hs
@@ -35,6 +35,7 @@ import qualified Language.PureScript as P
import qualified Data.Map as M
import Data.List (foldl')
import Language.PureScript.Sugar.Names.Env (nullImports, primExports)
+import Control.Monad (foldM)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Writer.Strict (runWriterT)
@@ -118,7 +119,7 @@ psciImportedModuleNames st =
-- ensure that completions remain accurate.
updateImportExports :: PSCiState -> PSCiState
updateImportExports st@(PSCiState modules lets externs iprint _ _) =
- case desugarModule [temporaryModule] of
+ case createEnv (map snd externs) >>= flip desugarModule [temporaryModule] of
Left _ -> st -- TODO: can this fail and what should we do?
Right (env, _) ->
case M.lookup temporaryName env of
@@ -126,9 +127,11 @@ updateImportExports st@(PSCiState modules lets externs iprint _ _) =
_ -> st -- impossible
where
- desugarModule :: [P.Module] -> Either P.MultipleErrors (P.Env, [P.Module])
- desugarModule = runExceptT =<< hushWarnings . P.desugarImportsWithEnv (map snd externs)
- hushWarnings = fmap fst . runWriterT
+ desugarModule :: P.Env -> [P.Module] -> Either P.MultipleErrors (P.Env, [P.Module])
+ desugarModule e = runExceptT =<< fmap fst . runWriterT . P.desugarImportsWithEnv e
+
+ createEnv :: [P.ExternsFile] -> Either P.MultipleErrors P.Env
+ createEnv = runExceptT =<< fmap fst . runWriterT . foldM P.externsEnv P.primEnv
temporaryName :: P.ModuleName
temporaryName = P.ModuleName [P.ProperName "$PSCI"]
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index 86686d6..0e7d19c 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -98,7 +98,7 @@ kindFromJSON defaultAnn annFromJSON = A.withObject "Kind" $ \o -> do
go :: Value -> Parser (Kind a)
go = kindFromJSON defaultAnn annFromJSON
--- These overlapping instances exist to preserve compatability for common
+-- These overlapping instances exist to preserve compatibility for common
-- instances which have a sensible default for missing annotations.
instance {-# OVERLAPPING #-} A.FromJSON (Kind SourceAnn) where
parseJSON = kindFromJSON (pure NullSourceAnn) A.parseJSON
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 55b3ebf..ec4b625 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -17,6 +17,7 @@ import Control.Monad.IO.Class
import Control.Monad.Supply
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Writer.Strict (runWriterT)
import Data.Function (on)
import Data.Foldable (for_)
import Data.List (foldl', sortBy)
@@ -57,13 +58,25 @@ rebuildModule
-> [ExternsFile]
-> Module
-> m ExternsFile
-rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
+rebuildModule actions externs m = do
+ env <- fmap fst . runWriterT $ foldM externsEnv primEnv externs
+ rebuildModule' actions env externs m
+
+rebuildModule'
+ :: forall m
+ . (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => MakeActions m
+ -> Env
+ -> [ExternsFile]
+ -> Module
+ -> m ExternsFile
+rebuildModule' MakeActions{..} exEnv externs m@(Module _ _ moduleName _ _) = do
progress $ CompilingModule moduleName
let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
withPrim = importPrim m
lint withPrim
((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
- desugar externs [withPrim] >>= \case
+ desugar exEnv externs [withPrim] >>= \case
[desugared] -> runCheck' (emptyCheckState env) $ typeCheckModule desugared
_ -> internalError "desugar did not return a singleton"
@@ -88,7 +101,7 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
-- a bug in the compiler, which should be reported as such.
-- 2. We do not want to perform any extra work generating docs unless the
-- user has asked for docs to be generated.
- let docs = case Docs.convertModule externs env' m of
+ let docs = case Docs.convertModule externs exEnv env' m of
Left errs -> internalError $
"Failed to produce docs for " ++ T.unpack (runModuleName moduleName)
++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs
@@ -138,6 +151,9 @@ make ma@MakeActions{..} ms = do
-- Write the updated build cache database to disk
writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb
+ -- If generating docs, also generate them for the Prim modules
+ outputPrimDocs
+
-- All threads have completed, rethrow any caught errors.
let errors = M.elems failures
unless (null errors) $ throwError (mconcat errors)
@@ -192,7 +208,17 @@ make ma@MakeActions{..} ms = do
case mexterns of
Just (_, externs) -> do
- (exts, warnings) <- listen $ rebuildModule ma externs m
+ -- We need to ensure that all dependencies have been included in Env
+ C.modifyMVar_ (bpEnv buildPlan) $ \env -> do
+ let
+ go :: Env -> ModuleName -> m Env
+ go e dep = case lookup dep (zip deps externs) of
+ Just exts
+ | not (M.member dep e) -> externsEnv e exts
+ _ -> return e
+ foldM go env deps
+ env <- C.readMVar (bpEnv buildPlan)
+ (exts, warnings) <- listen $ rebuildModule' ma env externs m
return $ BuildJobSucceeded warnings exts
Nothing -> return BuildJobSkipped
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 77374b1..b3fe5ee 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -36,6 +36,7 @@ import qualified Language.PureScript.CoreFn.ToJSON as CFJ
import qualified Language.PureScript.CoreImp.AST as Imp
import Language.PureScript.Crash
import qualified Language.PureScript.CST as CST
+import qualified Language.PureScript.Docs.Prim as Docs.Prim
import qualified Language.PureScript.Docs.Types as Docs
import Language.PureScript.Errors
import Language.PureScript.Externs (ExternsFile)
@@ -100,6 +101,8 @@ data MakeActions m = MakeActions
, writeCacheDb :: CacheDb -> m ()
-- ^ Write the given cache database to some external source (e.g. a file on
-- disk).
+ , outputPrimDocs :: m ()
+ -- ^ If generating docs, output the documentation for the Prim modules
}
-- | A set of make actions that read and write modules from the given directory.
@@ -114,7 +117,7 @@ buildMakeActions
-- ^ Generate a prefix comment?
-> MakeActions Make
buildMakeActions outputDir filePathMap foreigns usePrefix =
- MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb
+ MakeActions getInputTimestampsAndHashes getOutputTimestamp readExterns codegen ffiCodegen progress readCacheDb writeCacheDb outputPrimDocs
where
getInputTimestampsAndHashes
@@ -157,6 +160,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
let path = outputDir </> T.unpack (runModuleName mn) </> "externs.json"
(path, ) <$> readExternsFile path
+ outputPrimDocs :: Make ()
+ outputPrimDocs = do
+ codegenTargets <- asks optionsCodegenTargets
+ when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
+ writeJSONFile (outputFilename modName "docs.json") docsMod
+
codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
codegen m docs exts = do
let mn = CF.moduleName m
diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs
index 14f5181..8d409f6 100644
--- a/src/Language/PureScript/Make/BuildPlan.hs
+++ b/src/Language/PureScript/Make/BuildPlan.hs
@@ -1,5 +1,5 @@
module Language.PureScript.Make.BuildPlan
- ( BuildPlan()
+ ( BuildPlan(bpEnv)
, BuildJobResult(..)
, buildJobSuccess
, buildJobFailure
@@ -29,12 +29,14 @@ import Language.PureScript.Externs
import Language.PureScript.Make.Actions as Actions
import Language.PureScript.Make.Cache
import Language.PureScript.Names (ModuleName)
+import Language.PureScript.Sugar.Names.Env
-- | The BuildPlan tracks information about our build progress, and holds all
-- prebuilt modules for incremental builds.
data BuildPlan = BuildPlan
{ bpPrebuilt :: M.Map ModuleName Prebuilt
, bpBuildJobs :: M.Map ModuleName BuildJob
+ , bpEnv :: C.MVar Env
}
data Prebuilt = Prebuilt
@@ -140,8 +142,9 @@ construct MakeActions{..} cacheDb (sorted, graph) = do
mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses
let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames
buildJobs <- foldM makeBuildJob M.empty toBeRebuilt
+ env <- C.newMVar primEnv
pure
- ( BuildPlan prebuilt buildJobs
+ ( BuildPlan prebuilt buildJobs env
, let
update = flip $ \s ->
M.alter (const (statusNewCacheInfo s)) (statusModuleName s)
diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs
index f466257..48a042f 100644
--- a/src/Language/PureScript/PSString.hs
+++ b/src/Language/PureScript/PSString.hs
@@ -18,7 +18,7 @@ import GHC.Generics (Generic)
import Control.DeepSeq (NFData)
import Control.Exception (try, evaluate)
import Control.Applicative ((<|>))
-import Data.Char (chr)
+import qualified Data.Char as Char
import Data.Bits (shiftR)
import Data.List (unfoldr)
import Data.Scientific (toBoundedInteger)
@@ -67,7 +67,7 @@ instance Show PSString where
-- we do not export it.
--
codePoints :: PSString -> String
-codePoints = map (either (chr . fromIntegral) id) . decodeStringEither
+codePoints = map (either (Char.chr . fromIntegral) id) . decodeStringEither
-- |
-- Decode a PSString as UTF-16 text. Lone surrogates will be replaced with
@@ -94,14 +94,6 @@ decodeStringEither = unfoldr decode . toUTF16CodeUnits
unsurrogate h l = toEnum ((toInt h - 0xD800) * 0x400 + (toInt l - 0xDC00) + 0x10000)
-- |
--- Pretty print a PSString, using Haskell/PureScript escape sequences.
--- This is identical to the Show instance except that we get a Text out instead
--- of a String.
---
-prettyPrintString :: PSString -> Text
-prettyPrintString = T.pack . show
-
--- |
-- Attempt to decode a PSString as UTF-16 text. This will fail (returning
-- Nothing) if the argument contains lone surrogates.
--
@@ -156,6 +148,52 @@ instance A.FromJSON PSString where
parseCodeUnit b = A.withScientific "two-byte non-negative integer" (maybe (A.typeMismatch "" b) return . toBoundedInteger) b
-- |
+-- Pretty print a PSString, using PureScript escape sequences.
+--
+prettyPrintString :: PSString -> Text
+prettyPrintString s = "\"" <> foldMap encodeChar (decodeStringEither s) <> "\""
+ where
+ encodeChar :: Either Word16 Char -> Text
+ encodeChar (Left c) = "\\x" <> showHex' 6 c
+ encodeChar (Right c)
+ | c == '\t' = "\\t"
+ | c == '\r' = "\\r"
+ | c == '\n' = "\\n"
+ | c == '"' = "\\\""
+ | c == '\'' = "\\\'"
+ | c == '\\' = "\\\\"
+ | shouldPrint c = T.singleton c
+ | otherwise = "\\x" <> showHex' 6 (Char.ord c)
+
+ -- Note we do not use Data.Char.isPrint here because that includes things
+ -- like zero-width spaces and combining punctuation marks, which could be
+ -- confusing to print unescaped.
+ shouldPrint :: Char -> Bool
+ -- The standard space character, U+20 SPACE, is the only space char we should
+ -- print without escaping
+ shouldPrint ' ' = True
+ shouldPrint c =
+ Char.generalCategory c `elem`
+ [ Char.UppercaseLetter
+ , Char.LowercaseLetter
+ , Char.TitlecaseLetter
+ , Char.OtherLetter
+ , Char.DecimalNumber
+ , Char.LetterNumber
+ , Char.OtherNumber
+ , Char.ConnectorPunctuation
+ , Char.DashPunctuation
+ , Char.OpenPunctuation
+ , Char.InitialQuote
+ , Char.FinalQuote
+ , Char.OtherPunctuation
+ , Char.MathSymbol
+ , Char.CurrencySymbol
+ , Char.ModifierSymbol
+ , Char.OtherSymbol
+ ]
+
+-- |
-- Pretty print a PSString, using JavaScript escape sequences. Intended for
-- use in compiled JS output.
--
@@ -163,8 +201,8 @@ prettyPrintStringJS :: PSString -> Text
prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
where
encodeChar :: Word16 -> Text
- encodeChar c | c > 0xFF = "\\u" <> hex 4 c
- encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> hex 2 c
+ encodeChar c | c > 0xFF = "\\u" <> showHex' 4 c
+ encodeChar c | c > 0x7E || c < 0x20 = "\\x" <> showHex' 2 c
encodeChar c | toChar c == '\b' = "\\b"
encodeChar c | toChar c == '\t' = "\\t"
encodeChar c | toChar c == '\n' = "\\n"
@@ -175,10 +213,10 @@ prettyPrintStringJS s = "\"" <> foldMap encodeChar (toUTF16CodeUnits s) <> "\""
encodeChar c | toChar c == '\\' = "\\\\"
encodeChar c = T.singleton $ toChar c
- hex :: (Enum a) => Int -> a -> Text
- hex width c =
- let hs = showHex (fromEnum c) "" in
- T.pack (replicate (width - length hs) '0' <> hs)
+showHex' :: Enum a => Int -> a -> Text
+showHex' width c =
+ let hs = showHex (fromEnum c) "" in
+ T.pack (replicate (width - length hs) '0' <> hs)
isLead :: Word16 -> Bool
isLead h = h >= 0xD800 && h <= 0xDBFF
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 99d422c..da0d10b 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -54,10 +54,11 @@ import Language.PureScript.Sugar.TypeDeclarations as S
--
desugar
:: (MonadSupply m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => [ExternsFile]
+ => Env
+ -> [ExternsFile]
-> [Module]
-> m [Module]
-desugar externs =
+desugar env externs =
map desugarSignedLiterals
>>> traverse desugarObjectConstructors
>=> traverse desugarDoModule
@@ -65,7 +66,7 @@ desugar externs =
>=> map desugarLetPatternModule
>>> traverse desugarCasesModule
>=> traverse desugarTypeDeclarationsModule
- >=> desugarImports externs
+ >=> desugarImports env
>=> rebracket externs
>=> traverse checkFixityExports
>=> traverse (deriveInstances externs)
diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs
index f7e84bc..46f12a1 100644
--- a/src/Language/PureScript/Sugar/AdoNotation.hs
+++ b/src/Language/PureScript/Sugar/AdoNotation.hs
@@ -25,43 +25,44 @@ desugarAdoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds des
-- | Desugar a single ado statement
desugarAdo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
desugarAdo d =
- let (f, _, _) = everywhereOnValuesM return replace return
- in f d
+ let ss = declSourceSpan d
+ (f, _, _) = everywhereOnValuesM return (replace ss) return
+ in rethrowWithPosition ss $ f d
where
- pure' :: Maybe ModuleName -> Expr
- pure' m = Var nullSourceSpan (Qualified m (Ident C.pure'))
+ pure' :: SourceSpan -> Maybe ModuleName -> Expr
+ pure' ss m = Var ss (Qualified m (Ident C.pure'))
- map' :: Maybe ModuleName -> Expr
- map' m = Var nullSourceSpan (Qualified m (Ident C.map))
+ map' :: SourceSpan -> Maybe ModuleName -> Expr
+ map' ss m = Var ss (Qualified m (Ident C.map))
- apply :: Maybe ModuleName -> Expr
- apply m = Var nullSourceSpan (Qualified m (Ident C.apply))
+ apply :: SourceSpan -> Maybe ModuleName -> Expr
+ apply ss m = Var ss (Qualified m (Ident C.apply))
- replace :: Expr -> m Expr
- replace (Ado m els yield) = do
- (func, args) <- foldM go (yield, []) (reverse els)
+ replace :: SourceSpan -> Expr -> m Expr
+ replace pos (Ado m els yield) = do
+ (func, args) <- foldM (go pos) (yield, []) (reverse els)
return $ case args of
- [] -> App (pure' m) func
- hd : tl -> foldl' (\a b -> App (App (apply m) a) b) (App (App (map' m) func) hd) tl
- replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
- replace other = return other
+ [] -> App (pure' pos m) func
+ hd : tl -> foldl' (\a b -> App (App (apply pos m) a) b) (App (App (map' pos m) func) hd) tl
+ replace _ (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace pos v)
+ replace _ other = return other
- go :: (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr])
- go (yield, args) (DoNotationValue val) =
+ go :: SourceSpan -> (Expr, [Expr]) -> DoNotationElement -> m (Expr, [Expr])
+ go _ (yield, args) (DoNotationValue val) =
return (Abs NullBinder yield, val : args)
- go (yield, args) (DoNotationBind (VarBinder ss ident) val) =
+ go _ (yield, args) (DoNotationBind (VarBinder ss ident) val) =
return (Abs (VarBinder ss ident) yield, val : args)
- go (yield, args) (DoNotationBind binder val) = do
+ go ss (yield, args) (DoNotationBind binder val) = do
ident <- freshIdent'
- let abs = Abs (VarBinder nullSourceSpan ident)
- (Case [Var nullSourceSpan (Qualified Nothing ident)]
+ let abs = Abs (VarBinder ss ident)
+ (Case [Var ss (Qualified Nothing ident)]
[CaseAlternative [binder] [MkUnguarded yield]])
return (abs, val : args)
- go (yield, args) (DoNotationLet ds) = do
+ go _ (yield, args) (DoNotationLet ds) = do
return (Let FromLet ds yield, args)
- go acc (PositionedDoNotationElement pos com el) =
+ go _ acc (PositionedDoNotationElement pos com el) =
rethrowWithPosition pos $ do
- (yield, args) <- go acc el
+ (yield, args) <- go pos acc el
return $ case args of
[] -> (PositionedValue pos com yield, args)
(a : as) -> (yield, PositionedValue pos com a : as)
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 6199de9..a03457b 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -171,8 +171,8 @@ desugarGuardedExprs ss (Case scrut alternatives) =
-- if the binder is a var binder we must not add
-- the fail case as it results in unreachable
-- alternative
- alt_fail' | all isIrrefutable vb = []
- | otherwise = alt_fail
+ alt_fail' n | all isIrrefutable vb = []
+ | otherwise = alt_fail n
-- we are here:
@@ -186,18 +186,18 @@ desugarGuardedExprs ss (Case scrut alternatives) =
--
in Case scrut
(CaseAlternative vb [MkUnguarded (desugarGuard gs e alt_fail)]
- : alt_fail')
+ : (alt_fail' (length scrut)))
return [ CaseAlternative scrut_nullbinder [MkUnguarded rhs]]
- desugarGuard :: [Guard] -> Expr -> [CaseAlternative] -> Expr
+ desugarGuard :: [Guard] -> Expr -> (Int ->[CaseAlternative]) -> Expr
desugarGuard [] e _ = e
desugarGuard (ConditionGuard c : gs) e match_failed
| isTrueExpr c = desugarGuard gs e match_failed
| otherwise =
Case [c]
(CaseAlternative [LiteralBinder ss (BooleanLiteral True)]
- [MkUnguarded (desugarGuard gs e match_failed)] : match_failed)
+ [MkUnguarded (desugarGuard gs e match_failed)] : match_failed 1)
desugarGuard (PatternGuard vb g : gs) e match_failed =
Case [g]
@@ -206,7 +206,7 @@ desugarGuardedExprs ss (Case scrut alternatives) =
where
-- don't consider match_failed case if the binder is irrefutable
match_failed' | isIrrefutable vb = []
- | otherwise = match_failed
+ | otherwise = match_failed 1
-- we generate a let-binding for the remaining guards
-- and alternatives. A CaseAlternative is passed (or in
@@ -215,7 +215,7 @@ desugarGuardedExprs ss (Case scrut alternatives) =
desugarAltOutOfLine :: [Binder]
-> [GuardedExpr]
-> [CaseAlternative]
- -> ([CaseAlternative] -> Expr)
+ -> ((Int -> [CaseAlternative]) -> Expr)
-> m Expr
desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body
| Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do
@@ -228,7 +228,8 @@ desugarGuardedExprs ss (Case scrut alternatives) =
goto_rem_case :: Expr
goto_rem_case = Var ss (Qualified Nothing rem_case_id)
`App` Literal ss (BooleanLiteral True)
- alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]]
+ alt_fail :: Int -> [CaseAlternative]
+ alt_fail n = [CaseAlternative (replicate n NullBinder) [MkUnguarded goto_rem_case]]
pure $ Let FromLet [
ValueDecl (ss, []) rem_case_id Private []
@@ -236,7 +237,7 @@ desugarGuardedExprs ss (Case scrut alternatives) =
] (mk_body alt_fail)
| otherwise
- = pure $ mk_body []
+ = pure $ mk_body (const [])
where
mkCaseOfRemainingGuardsAndAlts
| not (null rem_guarded)
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 003580c..d7a9f71 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -7,8 +7,10 @@ module Language.PureScript.Sugar.DoNotation (desugarDoModule) where
import Prelude.Compat
+import Control.Applicative ((<|>))
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
+import Data.Maybe (fromMaybe)
import Data.Monoid (First(..))
import Language.PureScript.AST
import Language.PureScript.Crash
@@ -40,6 +42,13 @@ desugarDo d =
replace _ (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace pos v)
replace _ other = return other
+ stripPositionedBinder :: Binder -> (Maybe SourceSpan, Binder)
+ stripPositionedBinder (PositionedBinder ss _ b) =
+ let (ss', b') = stripPositionedBinder b
+ in (ss' <|> Just ss, b')
+ stripPositionedBinder b =
+ (Nothing, b)
+
go :: SourceSpan -> Maybe ModuleName -> [DoNotationElement] -> m Expr
go _ _ [] = internalError "The impossible happened in desugarDo"
go _ _ [DoNotationValue val] = return val
@@ -52,13 +61,18 @@ desugarDo d =
where
fromIdent (Ident i) | i `elem` [ C.bind, C.discard ] = First (Just i)
fromIdent _ = mempty
- go pos m (DoNotationBind (VarBinder ss ident) val : rest) = do
- rest' <- go pos m rest
- return $ App (App (bind pos m) val) (Abs (VarBinder ss ident) rest')
go pos m (DoNotationBind binder val : rest) = do
rest' <- go pos m rest
- ident <- freshIdent'
- return $ App (App (bind pos m) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']]))
+ let (mss, binder') = stripPositionedBinder binder
+ let ss = fromMaybe pos mss
+ case binder' of
+ NullBinder ->
+ return $ App (App (bind pos m) val) (Abs (VarBinder ss UnusedIdent) rest')
+ VarBinder _ ident ->
+ return $ App (App (bind pos m) val) (Abs (VarBinder ss ident) rest')
+ _ -> do
+ ident <- freshIdent'
+ return $ App (App (bind pos m) val) (Abs (VarBinder pos ident) (Case [Var pos (Qualified Nothing ident)] [CaseAlternative [binder] [MkUnguarded rest']]))
go _ _ [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet
go pos m (DoNotationLet ds : rest) = do
let checkBind :: Declaration -> m ()
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index fcf7f46..5aa7cb8 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -2,6 +2,7 @@ module Language.PureScript.Sugar.Names
( desugarImports
, desugarImportsWithEnv
, Env
+ , externsEnv
, primEnv
, ImportRecord(..)
, ImportProvenance(..)
@@ -16,7 +17,7 @@ import Control.Arrow (first)
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Lazy
-import Control.Monad.Writer (MonadWriter(..), censor)
+import Control.Monad.Writer (MonadWriter(..))
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Map as M
@@ -42,73 +43,22 @@ import Language.PureScript.Types
desugarImports
:: forall m
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => [ExternsFile]
+ => Env
-> [Module]
-> m [Module]
-desugarImports externs modules =
- fmap snd (desugarImportsWithEnv externs modules)
+desugarImports env modules =
+ fmap snd (desugarImportsWithEnv env modules)
desugarImportsWithEnv
:: forall m
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => [ExternsFile]
+ => Env
-> [Module]
-> m (Env, [Module])
-desugarImportsWithEnv externs modules = do
- env <- silence $ foldM externsEnv primEnv externs
- (modules', env') <- first reverse <$> foldM updateEnv ([], env) modules
+desugarImportsWithEnv e modules = do
+ (modules', env') <- first reverse <$> foldM updateEnv ([], e) modules
(env',) <$> traverse (renameInModule' env') modules'
where
- silence :: m a -> m a
- silence = censor (const mempty)
-
- -- | Create an environment from a collection of externs files
- externsEnv :: Env -> ExternsFile -> m Env
- externsEnv env ExternsFile{..} = do
- let members = Exports{..}
- env' = M.insert efModuleName (efSourceSpan, nullImports, members) env
- fromEFImport (ExternsImport mn mt qmn) = (mn, [(efSourceSpan, Just mt, qmn)])
- imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)
- exps <- resolveExports env' efSourceSpan efModuleName imps members efExports
- return $ M.insert efModuleName (efSourceSpan, imps, exps) env
- where
-
- -- An ExportSource for declarations local to the module which the given
- -- ExternsFile corresponds to.
- localExportSource =
- ExportSource { exportSourceDefinedIn = efModuleName
- , exportSourceImportedFrom = Nothing
- }
-
- exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
- exportedTypes = M.fromList $ mapMaybe toExportedType efExports
- where
- toExportedType (TypeRef _ tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, localExportSource))
- where
- forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)
- forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn
- forTyCon _ = Nothing
- toExportedType _ = Nothing
-
- exportedTypeOps :: M.Map (OpName 'TypeOpName) ExportSource
- exportedTypeOps = exportedRefs getTypeOpRef
-
- exportedTypeClasses :: M.Map (ProperName 'ClassName) ExportSource
- exportedTypeClasses = exportedRefs getTypeClassRef
-
- exportedValues :: M.Map Ident ExportSource
- exportedValues = exportedRefs getValueRef
-
- exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource
- exportedValueOps = exportedRefs getValueOpRef
-
- exportedKinds :: M.Map (ProperName 'KindName) ExportSource
- exportedKinds = exportedRefs getKindRef
-
- exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ExportSource
- exportedRefs f =
- M.fromList $ (, localExportSource) <$> mapMaybe f efExports
-
updateEnv :: ([Module], Env) -> Module -> m ([Module], Env)
updateEnv (ms, env) m@(Module ss _ mn _ refs) = do
members <- findExportable m
@@ -126,6 +76,58 @@ desugarImportsWithEnv externs modules = do
lintImports m'' env used
return m''
+-- | Create an environment from a collection of externs files
+externsEnv
+ :: forall m
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
+ => Env
+ -> ExternsFile
+ -> m Env
+externsEnv env ExternsFile{..} = do
+ let members = Exports{..}
+ env' = M.insert efModuleName (efSourceSpan, nullImports, members) env
+ fromEFImport (ExternsImport mn mt qmn) = (mn, [(efSourceSpan, Just mt, qmn)])
+ imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports)
+ exps <- resolveExports env' efSourceSpan efModuleName imps members efExports
+ return $ M.insert efModuleName (efSourceSpan, imps, exps) env
+ where
+
+ -- An ExportSource for declarations local to the module which the given
+ -- ExternsFile corresponds to.
+ localExportSource =
+ ExportSource { exportSourceDefinedIn = efModuleName
+ , exportSourceImportedFrom = Nothing
+ }
+
+ exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
+ exportedTypes = M.fromList $ mapMaybe toExportedType efExports
+ where
+ toExportedType (TypeRef _ tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, localExportSource))
+ where
+ forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName)
+ forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn
+ forTyCon _ = Nothing
+ toExportedType _ = Nothing
+
+ exportedTypeOps :: M.Map (OpName 'TypeOpName) ExportSource
+ exportedTypeOps = exportedRefs getTypeOpRef
+
+ exportedTypeClasses :: M.Map (ProperName 'ClassName) ExportSource
+ exportedTypeClasses = exportedRefs getTypeClassRef
+
+ exportedValues :: M.Map Ident ExportSource
+ exportedValues = exportedRefs getValueRef
+
+ exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource
+ exportedValueOps = exportedRefs getValueOpRef
+
+ exportedKinds :: M.Map (ProperName 'KindName) ExportSource
+ exportedKinds = exportedRefs getKindRef
+
+ exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ExportSource
+ exportedRefs f =
+ M.fromList $ (, localExportSource) <$> mapMaybe f efExports
+
-- |
-- Make all exports for a module explicit. This may still affect modules that
-- have an exports list, as it will also make all data constructor exports
diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs
index 5cf6851..a038d38 100644
--- a/src/Language/PureScript/Sugar/Operators/Common.hs
+++ b/src/Language/PureScript/Sugar/Operators/Common.hs
@@ -96,7 +96,7 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains
-- grouping them by shared precedence, then if any of the following conditions
-- are met, we have something to report:
-- 1. any of the groups have mixed associativity
- -- 2. there is more than one occurance of a non-associative operator in a
+ -- 2. there is more than one occurrence of a non-associative operator in a
-- precedence group
mkErrors :: Chain a -> [ErrorMessage]
mkErrors chain =
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index 170ea7e..bfd47dd 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -30,7 +30,7 @@ newSkolemConstant = do
modify $ \st -> st { checkNextSkolem = s + 1 }
return s
--- | Introduce skolem scope at every occurence of a ForAll
+-- | Introduce skolem scope at every occurrence of a ForAll
introduceSkolemScope :: MonadState CheckState m => Type a -> m (Type a)
introduceSkolemScope = everywhereOnTypesM go
where
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index b0bc93d..24e1d97 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -25,7 +25,7 @@ module Language.PureScript.TypeChecker.Types
-}
import Prelude.Compat
-import Protolude (ordNub)
+import Protolude (ordNub, fold, atMay)
import Control.Arrow (first, second, (***))
import Control.Monad
@@ -110,21 +110,56 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
. throwError
. errorMessage' ss
$ CannotGeneralizeRecursiveFunction ident generalized
- -- Make sure any unsolved type constraints only use type variables which appear
- -- unknown in the inferred type.
- forM_ unsolved $ \(_, _, con) -> do
- -- We need information about functional dependencies, since we allow
- -- ambiguous types to be inferred if they can be solved by some functional
- -- dependency.
+ -- We need information about functional dependencies, since we allow
+ -- ambiguous types to be inferred if they can be solved by some functional
+ -- dependency.
+ conData <- forM unsolved $ \(_, _, con) -> do
let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup (constraintClass con)
TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv)
- let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies
- let constraintTypeVars = ordNub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..]
- when (any (`notElem` unsolvedTypeVars) constraintTypeVars) .
- throwError
- . onErrorMessages (replaceTypes currentSubst)
- . errorMessage' ss
- $ AmbiguousTypeVariables generalized con
+ let
+ -- The set of unknowns mentioned in each argument.
+ unknownsForArg :: [S.Set Int]
+ unknownsForArg =
+ map (S.fromList . map snd . unknownsInType) (constraintArgs con)
+ pure (typeClassDependencies, unknownsForArg)
+ -- Make sure any unsolved type constraints are determined by the
+ -- type variables which appear unknown in the inferred type.
+ let
+ -- Take the closure of fundeps across constraints, to get more
+ -- and more solved variables until reaching a fixpoint.
+ solveFrom :: S.Set Int -> S.Set Int
+ solveFrom determined = do
+ let solved = solve1 determined
+ if solved `S.isSubsetOf` determined
+ then determined
+ else solveFrom (determined <> solved)
+ solve1 :: S.Set Int -> S.Set Int
+ solve1 determined = fold $ do
+ (tcDeps, conArgUnknowns) <- conData
+ let
+ lookupUnknowns :: Int -> Maybe (S.Set Int)
+ lookupUnknowns = atMay conArgUnknowns
+ unknownsDetermined :: Maybe (S.Set Int) -> Bool
+ unknownsDetermined Nothing = False
+ unknownsDetermined (Just unknowns) =
+ unknowns `S.isSubsetOf` determined
+ -- If all of the determining arguments of a particular fundep are
+ -- already determined, add the determined arguments from the fundep
+ tcDep <- tcDeps
+ guard $ all (unknownsDetermined . lookupUnknowns) (fdDeterminers tcDep)
+ map (fromMaybe S.empty . lookupUnknowns) (fdDetermined tcDep)
+ -- These unknowns can be determined from the body of the inferred
+ -- type (i.e. excluding the unknowns mentioned in the constraints)
+ let determinedFromType = S.fromList . map snd $ unsolvedTypeVars
+ -- These are all the unknowns mentioned in the constraints
+ let constraintTypeVars = fold (conData >>= snd)
+ let solved = solveFrom determinedFromType
+ let unsolvedVars = S.difference constraintTypeVars solved
+ when (not (S.null unsolvedVars)) .
+ throwError
+ . onErrorMessages (replaceTypes currentSubst)
+ . errorMessage' ss
+ $ AmbiguousTypeVariables generalized (S.toList unsolvedVars)
-- Check skolem variables did not escape their scope
skolemEscapeCheck val'
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index ae22b11..06c752a 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -321,7 +321,7 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do
go :: A.Value -> A.Parser (Type a)
go = typeFromJSON defaultAnn annFromJSON
--- These overlapping instances exist to preserve compatability for common
+-- These overlapping instances exist to preserve compatibility for common
-- instances which have a sensible default for missing annotations.
instance {-# OVERLAPPING #-} A.FromJSON (Type SourceAnn) where
parseJSON = typeFromJSON (pure NullSourceAnn) A.parseJSON
diff --git a/tests/purs/passing/3238.purs b/tests/purs/passing/3238.purs
new file mode 100644
index 0000000..5c40f23
--- /dev/null
+++ b/tests/purs/passing/3238.purs
@@ -0,0 +1,14 @@
+module Main where
+
+import Effect.Console (log)
+
+class C a
+
+class FD a b | a -> b
+
+fn1 :: forall a b. FD a b => C b => a -> String
+fn1 _ = ""
+
+fn2 x = fn1 x
+
+main = log "Done"
diff --git a/tests/purs/passing/Guards.purs b/tests/purs/passing/Guards.purs
index 2894d2e..c62c0bd 100644
--- a/tests/purs/passing/Guards.purs
+++ b/tests/purs/passing/Guards.purs
@@ -34,6 +34,12 @@ clunky1 a b | x <- max a b
= x
clunky1 a _ = a
+clunky1_refutable :: Int -> Int -> Int
+clunky1_refutable 0 a | x <- max a a
+ , x > 5
+ = x
+clunky1_refutable a _ = a
+
clunky2 :: Int -> Int -> Int
clunky2 a b | x <- max a b
, x > 5
diff --git a/tests/purs/warning/ScopeShadowing.purs b/tests/purs/warning/ScopeShadowing.purs
index 380a4ee..848eaf9 100644
--- a/tests/purs/warning/ScopeShadowing.purs
+++ b/tests/purs/warning/ScopeShadowing.purs
@@ -7,7 +7,7 @@ import Prelude
data Unit = Unit
-- This is only a warning as the `Prelude` import is implicit. If `Unit` was
--- named explicitly in an import list, then this refernce to `Unit`
+-- named explicitly in an import list, then this reference to `Unit`
-- would be a `ScopeConflict` error instead.
test :: Unit
test = const Unit unit