diff options
author | hdgarrood <> | 2020-01-18 16:10:00 (GMT) |
---|---|---|
committer | hdiff <hdiff@hdiff.luite.com> | 2020-01-18 16:10:00 (GMT) |
commit | 27a66e51ef65d927736c86e64f820e93fd6b3c65 (patch) | |
tree | f2308d44b832e7b32d81854ff3567aa5ccb3679d | |
parent | 8be6c7045bf80d275a59ee3bc1d17c6cd07f95e4 (diff) |
version 0.13.60.13.6
28 files changed, 383 insertions, 294 deletions
@@ -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 |