From 42b7e6a701c628ccd6e8a27aeff837200b90dfbd Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Fri, 9 May 2025 22:24:11 +0000 Subject: [PATCH 01/19] Module name --- purescript.cabal | 1 + src/Language/PureScript/CST/Convert.hs | 2 +- src/Language/PureScript/CST/Utils.hs | 4 +- src/Language/PureScript/CodeGen/JS/Common.hs | 6 +-- src/Language/PureScript/CoreFn/FromJSON.hs | 4 +- src/Language/PureScript/CoreFn/ToJSON.hs | 4 +- src/Language/PureScript/Hierarchy.hs | 4 +- src/Language/PureScript/InternedText.hs | 47 ++++++++++++++++++++ src/Language/PureScript/Make.hs | 4 +- src/Language/PureScript/Names.hs | 23 ++++++---- tests/Language/PureScript/Ide/FilterSpec.hs | 4 +- tests/TestDocs.hs | 5 ++- tests/TestUtils.hs | 3 +- 13 files changed, 82 insertions(+), 29 deletions(-) create mode 100644 src/Language/PureScript/InternedText.hs diff --git a/purescript.cabal b/purescript.cabal index e5823202a6..7838188504 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -342,6 +342,7 @@ library Language.PureScript.Make.Monad Language.PureScript.ModuleDependencies Language.PureScript.Names + Language.PureScript.InternedText Language.PureScript.Options Language.PureScript.Pretty Language.PureScript.Pretty.Common diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index c75d333dcc..c51ebf170f 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -87,7 +87,7 @@ moduleName = \case _ -> Nothing where go [] = Nothing - go ns = Just $ N.ModuleName $ Text.intercalate "." ns + go ns = Just $ N.moduleNameFromString $ Text.intercalate "." ns qualified :: QualifiedName a -> N.Qualified a qualified q = N.Qualified qb (qualName q) diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs index b941cf5fcf..5ca886e369 100644 --- a/src/Language/PureScript/CST/Utils.hs +++ b/src/Language/PureScript/CST/Utils.hs @@ -120,14 +120,14 @@ toModuleName :: SourceToken -> [Text] -> Parser (Maybe N.ModuleName) toModuleName _ [] = pure Nothing toModuleName tok ns = do unless (all isValidModuleNamespace ns) $ addFailure [tok] ErrModuleName - pure . Just . N.ModuleName $ Text.intercalate "." ns + pure . Just . N.moduleNameFromString $ Text.intercalate "." ns upperToModuleName :: SourceToken -> Parser (Name N.ModuleName) upperToModuleName tok = case tokValue tok of TokUpperName q a -> do let ns = q <> [a] unless (all isValidModuleNamespace ns) $ addFailure [tok] ErrModuleName - pure . Name tok . N.ModuleName $ Text.intercalate "." ns + pure . Name tok . N.moduleNameFromString $ Text.intercalate "." ns _ -> internalError $ "Invalid upper name: " <> show tok toQualifiedName :: (Text -> a) -> SourceToken -> Parser (QualifiedName a) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index e029468908..e1b6094a2f 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -8,11 +8,11 @@ import Data.Text (Text) import Data.Text qualified as T import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (Ident(..), InternalIdentData(..), ModuleName(..), ProperName(..), unusedIdent) +import Language.PureScript.Names (Ident(..), InternalIdentData(..), runModuleName, ProperName(..), unusedIdent, ModuleName) moduleNameToJs :: ModuleName -> Text -moduleNameToJs (ModuleName mn) = - let name = T.replace "." "_" mn +moduleNameToJs mn = + let name = T.replace "." "_" (runModuleName mn) in if nameIsJsBuiltIn name then "$$" <> name else name -- | Convert an 'Ident' into a valid JavaScript identifier: diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index d0426b6f8d..984898ba2a 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -23,7 +23,7 @@ import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn (Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Meta(..), Module(..)) -import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), unusedIdent) +import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), unusedIdent, moduleNameFromString) import Language.PureScript.PSString (PSString) import Text.ParserCombinators.ReadP (readP_to_S) @@ -125,7 +125,7 @@ qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj pure $ Qualified (BySourcePos ss) i moduleNameFromJSON :: Value -> Parser ModuleName -moduleNameFromJSON v = ModuleName . T.intercalate "." <$> listParser parseJSON v +moduleNameFromJSON v = moduleNameFromString . T.intercalate "." <$> listParser parseJSON v moduleFromJSON :: Value -> Parser (Version, Module Ann) moduleFromJSON = withObject "Module" moduleFromObj diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 1b20ac4e65..be1b9d7242 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -23,7 +23,7 @@ import Data.Text qualified as T import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Meta(..), Module(..)) -import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), runIdent) +import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName) import Language.PureScript.PSString (PSString) constructorTypeToJSON :: ConstructorType -> Value @@ -114,7 +114,7 @@ qualifiedToJSON f (Qualified qb a) = ] moduleNameToJSON :: ModuleName -> Value -moduleNameToJSON (ModuleName name) = toJSON (T.splitOn (T.pack ".") name) +moduleNameToJSON mn = toJSON (T.splitOn (T.pack ".") $ runModuleName mn) moduleToJSON :: Version -> Module Ann -> Value moduleToJSON v m = object diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index c4919fb60d..09fb792bda 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -54,8 +54,8 @@ prettyPrint (SuperMap (Right (super, sub))) = " " <> P.runProperName super <> " -> " <> P.runProperName sub <> ";" runModuleName :: P.ModuleName -> GraphName -runModuleName (P.ModuleName name) = - GraphName $ T.replace "." "_" name +runModuleName mn = + GraphName $ T.replace "." "_" (P.runModuleName mn) typeClasses :: Functor f => f P.Module -> f (Maybe Graph) typeClasses = diff --git a/src/Language/PureScript/InternedText.hs b/src/Language/PureScript/InternedText.hs new file mode 100644 index 0000000000..b56420bfae --- /dev/null +++ b/src/Language/PureScript/InternedText.hs @@ -0,0 +1,47 @@ +module Language.PureScript.InternedText + ( InternedName + , intern + , unintern + , IsString (..) + ) where + +import Prelude +import Control.Concurrent.MVar +import Data.Map.Strict qualified as M +import Data.IntMap.Strict qualified as IM +import System.IO.Unsafe (unsafePerformIO) +import Data.Text (Text) +import Data.String (IsString(..)) +import Control.DeepSeq (NFData) +import GHC.Stack (HasCallStack) + +newtype InternedName = InternedName Int + deriving (Show) + deriving newtype (NFData, Eq, Ord) + +instance IsString InternedName where + fromString s = intern (fromString s) + +-- Global state +{-# NOINLINE interner #-} +interner :: MVar (M.Map Text InternedName, IM.IntMap Text, InternedName) +interner = unsafePerformIO $ newMVar (M.empty, IM.empty, InternedName 0) + +intern :: Text -> InternedName +intern s = unsafePerformIO $ do + modifyMVar interner $ \(m, im, next) -> + case M.lookup s m of + Just i -> pure ((m, im, next), i) + Nothing -> + let i@(InternedName ii) = next + next' = InternedName (ii + 1) + in pure ((M.insert s i m, IM.insert ii s im, next'), i) + + +unintern :: HasCallStack => InternedName -> Text +unintern (InternedName i) = unsafePerformIO $ do + (_, im, _) <- readMVar interner + case IM.lookup i im of + Just s -> pure s + Nothing -> error $ "Unknown interned name: " ++ show i + diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index a8f22ee0f4..86b23d7c08 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -247,8 +247,8 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do -- Here we return all the ExternsFile in the ordering of the topological sort, -- so they can be folded into an Environment. This result is used in the tests -- and in PSCI. - let lookupResult mn@(ModuleName name) = - fromMaybe (internalError $ "make: module not found in results: " <> T.unpack name) + let lookupResult mn = + fromMaybe (internalError $ "make: module not found in results: " <> T.unpack (runModuleName mn)) $ M.lookup mn successes pure $ diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 094ae5773d..5e3215e396 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -7,7 +7,7 @@ module Language.PureScript.Names where import Prelude -import Codec.Serialise (Serialise) +import Codec.Serialise (Serialise (..)) import Control.Applicative ((<|>)) import Control.Monad.Supply.Class (MonadSupply(..)) import Control.DeepSeq (NFData) @@ -22,6 +22,8 @@ import Data.Text qualified as T import Data.Int (Int64) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) +import Language.PureScript.InternedText (InternedName, unintern, intern) +import GHC.Stack (HasCallStack) -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -188,20 +190,23 @@ coerceProperName = ProperName . runProperName -- | -- Module names -- -newtype ModuleName = ModuleName Text +newtype ModuleName = ModuleName InternedName deriving (Show, Eq, Ord, Generic) - deriving newtype Serialise + +instance Serialise ModuleName where + encode (ModuleName i) = encode (unintern i) + decode = ModuleName . intern <$> decode instance NFData ModuleName -runModuleName :: ModuleName -> Text -runModuleName (ModuleName name) = name +runModuleName :: HasCallStack => ModuleName -> Text +runModuleName (ModuleName name) = unintern name moduleNameFromString :: Text -> ModuleName -moduleNameFromString = ModuleName +moduleNameFromString = ModuleName . intern isBuiltinModuleName :: ModuleName -> Bool -isBuiltinModuleName (ModuleName mn) = mn == "Prim" || "Prim." `T.isPrefixOf` mn +isBuiltinModuleName (ModuleName mn') = let mn = unintern mn' in mn == "Prim" || "Prim." `T.isPrefixOf` mn data QualifiedBy = BySourcePos SourcePos @@ -306,12 +311,12 @@ instance FromJSON a => FromJSON (Qualified a) where pure $ Qualified (byMaybeModuleName mn) a instance ToJSON ModuleName where - toJSON (ModuleName name) = toJSON (T.splitOn "." name) + toJSON mn = toJSON (T.splitOn "." $ runModuleName mn) instance FromJSON ModuleName where parseJSON = withArray "ModuleName" $ \names -> do names' <- traverse parseJSON names - pure (ModuleName (T.intercalate "." (V.toList names'))) + pure (moduleNameFromString (T.intercalate "." (V.toList names'))) instance ToJSONKey ModuleName where toJSONKey = contramap runModuleName toJSONKey diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 80eb127bd8..8604ed3b48 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -50,10 +50,10 @@ runDependency :: [Text] -> [Module] runDependency = runDependency' "Whatever" runDependency' :: Text -> [Text] -> [Module] -runDependency' currentModuleName imports = Map.toList $ applyFilters [dependencyFilter Nothing (P.ModuleName currentModuleName) (testParseImports currentModuleName imports)] allModules +runDependency' currentModuleName imports = Map.toList $ applyFilters [dependencyFilter Nothing (P.moduleNameFromString currentModuleName) (testParseImports currentModuleName imports)] allModules runDependencyQualified :: Text -> [Text] -> [Module] -runDependencyQualified qualifier imports = Map.toList $ applyFilters [dependencyFilter (Just $ P.ModuleName qualifier) (P.ModuleName "Whatever") (testParseImports "Whatever" imports)] allModules +runDependencyQualified qualifier imports = Map.toList $ applyFilters [dependencyFilter (Just $ P.moduleNameFromString qualifier) (P.ModuleName "Whatever") (testParseImports "Whatever" imports)] allModules testParseImports :: Text -> [Text] -> [Import] testParseImports currentModuleName imports = either (const []) (\(_, _, x, _) -> x) $ sliceImportSection moduleLines diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index d2b805ff0e..02ad1f4f84 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -2,6 +2,7 @@ module TestDocs where import Prelude +import GHC.Stack (HasCallStack) import Data.Bifunctor (first) import Data.List (findIndex) import Data.Foldable (find, forM_) @@ -125,7 +126,7 @@ data TagsAssertion -- | Assert that a particular declaration is not tagged | ShouldNotBeTagged Text -displayAssertion :: DocsAssertion -> Text +displayAssertion :: HasCallStack => DocsAssertion -> Text displayAssertion = \case ShouldBeDocumented mn decl children -> showQual mn decl <> " should be documented" <> @@ -977,7 +978,7 @@ testTagsCases = ]) ] -showQual :: P.ModuleName -> Text -> Text +showQual :: HasCallStack => P.ModuleName -> Text -> Text showQual mn decl = P.runModuleName mn <> "." <> decl diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index 97ea465999..2324dc3ca5 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -5,7 +5,6 @@ import Prelude import Language.PureScript qualified as P import Language.PureScript.CST qualified as CST import Language.PureScript.AST qualified as AST -import Language.PureScript.Names qualified as N import Language.PureScript.Interactive.IO (findNodeProcess) import Control.Arrow ((***), (>>>)) @@ -235,7 +234,7 @@ compile' options expectedModule SupportModules{..} inputFiles = do getPsModuleName :: (a, AST.Module) -> T.Text getPsModuleName psModule = case snd psModule of - AST.Module _ _ (N.ModuleName t) _ _ -> t + AST.Module _ _ mn _ _ -> P.runModuleName mn makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False) From ab7348a9f9261e6908b0a7f233ac57266527de82 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Fri, 9 May 2025 23:19:00 +0000 Subject: [PATCH 02/19] Add proper name interning --- src/Language/PureScript/CST/Parser.y | 6 ++--- src/Language/PureScript/CodeGen/JS.hs | 2 +- src/Language/PureScript/CodeGen/JS/Common.hs | 2 +- src/Language/PureScript/CoreFn/CSE.hs | 4 ++-- src/Language/PureScript/CoreFn/Desugar.hs | 2 +- src/Language/PureScript/CoreFn/FromJSON.hs | 8 +++---- src/Language/PureScript/CoreFn/ToJSON.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 4 ++-- .../PureScript/Docs/Convert/ReExports.hs | 2 +- src/Language/PureScript/Docs/Render.hs | 2 +- .../PureScript/Docs/RenderedCode/Types.hs | 4 ++-- src/Language/PureScript/Environment.hs | 4 ++-- src/Language/PureScript/Ide/State.hs | 6 ++--- src/Language/PureScript/InternedText.hs | 2 +- src/Language/PureScript/Names.hs | 23 ++++++++++++++----- src/Language/PureScript/Pretty/Types.hs | 2 +- src/Language/PureScript/Pretty/Values.hs | 2 +- .../PureScript/Sugar/TypeClasses/Deriving.hs | 2 +- .../PureScript/TypeChecker/Deriving.hs | 6 ++--- .../PureScript/TypeChecker/Entailment.hs | 2 +- src/Language/PureScript/TypeChecker/Kinds.hs | 22 +++++++++--------- src/Language/PureScript/TypeChecker/Monad.hs | 6 ++--- src/Language/PureScript/TypeChecker/Types.hs | 8 +++---- .../PureScript/TypeClassDictionaries.hs | 2 +- 24 files changed, 68 insertions(+), 57 deletions(-) diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y index 55aa95da79..ed14f90c6f 100644 --- a/src/Language/PureScript/CST/Parser.y +++ b/src/Language/PureScript/CST/Parser.y @@ -180,11 +180,11 @@ moduleName :: { Name N.ModuleName } | QUAL_UPPER {% upperToModuleName $1 } qualProperName :: { QualifiedProperName } - : UPPER {% qualifiedProperName <\$> toQualifiedName N.ProperName $1 } - | QUAL_UPPER {% qualifiedProperName <\$> toQualifiedName N.ProperName $1 } + : UPPER {% qualifiedProperName <\$> toQualifiedName N.properNameFromString $1 } + | QUAL_UPPER {% qualifiedProperName <\$> toQualifiedName N.properNameFromString $1 } properName :: { ProperName } - : UPPER {% properName <\$> toName N.ProperName $1 } + : UPPER {% properName <\$> toName N.properNameFromString $1 } qualIdent :: { QualifiedName Ident } : LOWER {% toQualifiedName Ident $1 } diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 14d122a37d..f598fa6602 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -40,7 +40,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), MultipleErrors(..), rethrow, errorMessage, errorMessage', rethrowWithPosition, addHint) -import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified) +import Language.PureScript.Names (Ident(..), ModuleName, Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified, runProperName) import Language.PureScript.Options (CodegenTarget(..), Options(..)) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) diff --git a/src/Language/PureScript/CodeGen/JS/Common.hs b/src/Language/PureScript/CodeGen/JS/Common.hs index e1b6094a2f..1a719d02f1 100644 --- a/src/Language/PureScript/CodeGen/JS/Common.hs +++ b/src/Language/PureScript/CodeGen/JS/Common.hs @@ -8,7 +8,7 @@ import Data.Text (Text) import Data.Text qualified as T import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (Ident(..), InternalIdentData(..), runModuleName, ProperName(..), unusedIdent, ModuleName) +import Language.PureScript.Names (Ident(..), InternalIdentData(..), runModuleName, ProperName(..), unusedIdent, ModuleName, runProperName) moduleNameToJs :: ModuleName -> Text moduleNameToJs mn = diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index e3e59bddad..a79bf5c78c 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -26,7 +26,7 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) import Language.PureScript.CoreFn.Meta (Meta(IsSyntheticApp)) import Language.PureScript.CoreFn.Traversals (everywhereOnValues, traverseCoreFn) import Language.PureScript.Environment (dictTypeName) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString) import Language.PureScript.PSString (decodeString) -- | @@ -248,7 +248,7 @@ generateIdentFor d e = at d . non mempty . at e %%<~ \case nameHint = \case App _ v1 v2 | Var _ n <- v1 - , fmap (ProperName . runIdent) n == fmap dictTypeName C.IsSymbol + , fmap (properNameFromString . runIdent) n == fmap dictTypeName C.IsSymbol , Literal _ (ObjectLiteral [(_, Abs _ _ (Literal _ (StringLiteral str)))]) <- v2 , Just decodedStr <- decodeString str -> decodedStr <> "IsSymbol" diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 34bf08f1f3..484ca67ee3 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -23,7 +23,7 @@ import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, runProperName) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST qualified as A diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 984898ba2a..3057d4702c 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -23,7 +23,7 @@ import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn (Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Meta(..), Module(..)) -import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), unusedIdent, moduleNameFromString) +import Language.PureScript.Names (Ident(..), ModuleName(..), properNameFromString, Qualified(..), QualifiedBy(..), unusedIdent, moduleNameFromString, ProperName) import Language.PureScript.PSString (PSString) import Text.ParserCombinators.ReadP (readP_to_S) @@ -108,7 +108,7 @@ identFromJSON = withText "Ident" $ \case | otherwise -> pure $ Ident ident properNameFromJSON :: Value -> Parser (ProperName a) -properNameFromJSON = fmap ProperName . parseJSON +properNameFromJSON = fmap properNameFromString . parseJSON qualifiedFromJSON :: (Text -> a) -> Value -> Parser (Qualified a) qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj @@ -307,8 +307,8 @@ binderFromJSON modulePath = withObject "Binder" binderFromObj constructorBinderFromObj o = do ann <- o .: "annotation" >>= annFromJSON modulePath - tyn <- o .: "typeName" >>= qualifiedFromJSON ProperName - con <- o .: "constructorName" >>= qualifiedFromJSON ProperName + tyn <- o .: "typeName" >>= qualifiedFromJSON properNameFromString + con <- o .: "constructorName" >>= qualifiedFromJSON properNameFromString bs <- o .: "binders" >>= listParser (binderFromJSON modulePath) return $ ConstructorBinder ann tyn con bs diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index be1b9d7242..01552f4434 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -23,7 +23,7 @@ import Data.Text qualified as T import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Meta(..), Module(..)) -import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName) +import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName, runProperName) import Language.PureScript.PSString (PSString) constructorTypeToJSON :: ConstructorType -> Value diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index a7dc1758c7..f4f4c8fdcb 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -83,7 +83,7 @@ insertValueTypesAndAdjustKinds env m = where inferredRoles :: [P.Role] inferredRoles = do - let key = P.Qualified (P.ByModuleName (modName m)) (P.ProperName (declTitle d)) + let key = P.Qualified (P.ByModuleName (modName m)) (P.properNameFromString (declTitle d)) case Map.lookup key (P.types env) of Just (_, tyKind) -> case tyKind of P.DataType _ tySourceTyRole _ -> @@ -213,7 +213,7 @@ insertValueTypesAndAdjustKinds env m = insertInferredKind :: Declaration -> Text -> P.KindSignatureFor -> Declaration insertInferredKind d name keyword = let - key = P.Qualified (P.ByModuleName (modName m)) (P.ProperName name) + key = P.Qualified (P.ByModuleName (modName m)) (P.properNameFromString name) in case Map.lookup key (P.types env) of Just (inferredKind, _) -> if isUninteresting keyword inferredKind' diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 600b343a5b..5376a6a8a6 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -511,7 +511,7 @@ typeClassConstraintFor :: Declaration -> Maybe Constraint' typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ _ -> - Just (P.Constraint () (P.Qualified P.ByNullSourcePos (P.ProperName declTitle)) [] (mkConstraint tyArgs) Nothing) + Just (P.Constraint () (P.Qualified P.ByNullSourcePos (P.properNameFromString declTitle)) [] (mkConstraint tyArgs) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 3a0038d989..5d486e43c8 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -123,7 +123,7 @@ renderConstraints constraints (map renderConstraint constraints) notQualified :: Text -> P.Qualified (P.ProperName a) -notQualified = P.Qualified P.ByNullSourcePos . P.ProperName +notQualified = P.Qualified P.ByNullSourcePos . P.properNameFromString ident' :: Text -> RenderedCode ident' = ident . P.Qualified P.ByNullSourcePos . P.Ident diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index c1374899f5..ab5753a801 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -45,7 +45,7 @@ import Data.Text qualified as T import Data.ByteString.Lazy qualified as BS import Data.Text.Encoding qualified as TE -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName, runProperName, properNameFromString) import Language.PureScript.AST (Associativity(..)) -- | Given a list of actions, attempt them all, returning the first success. @@ -298,7 +298,7 @@ aliasName for name' = ValueLevel -> ident (Qualified ByNullSourcePos (Ident name)) TypeLevel -> - typeCtor (Qualified ByNullSourcePos (ProperName name)) + typeCtor (Qualified ByNullSourcePos (properNameFromString name)) -- | Converts a FixityAlias into a different representation which is more -- useful to other functions in this module. diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 0c087e9cf1..56cd2c21b1 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -22,7 +22,7 @@ import Data.List.NonEmpty qualified as NEL import Language.PureScript.AST.SourcePos (nullSourceAnn) import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName) +import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName, runProperName, properNameFromString) import Language.PureScript.Roles (Role(..)) import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor, freeTypeVariables) @@ -665,7 +665,7 @@ dictTypeName' :: Text -> Text dictTypeName' = (<> "$Dict") dictTypeName :: ProperName a -> ProperName a -dictTypeName = ProperName . dictTypeName' . runProperName +dictTypeName = properNameFromString . dictTypeName' . runProperName isDictTypeName :: ProperName a -> Bool isDictTypeName = T.isSuffixOf "$Dict" . runProperName diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 06eed507e4..14818e1392 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -338,9 +338,9 @@ resolveDocumentationForModule (P.Module _ moduleComments moduleName sdecls _) = convertDeclaration' (annotateValue . P.IdentName) (annotateValue . P.IdentName . P.Ident) - (annotateValue . P.DctorName . P.ProperName) - (annotateValue . P.TyName . P.ProperName) - (annotateValue . P.TyClassName . P.ProperName) + (annotateValue . P.DctorName . P.properNameFromString) + (annotateValue . P.TyName . P.properNameFromString) + (annotateValue . P.TyClassName . P.properNameFromString) (annotateValue . P.ModName . P.moduleNameFromString) d where diff --git a/src/Language/PureScript/InternedText.hs b/src/Language/PureScript/InternedText.hs index b56420bfae..d8e4ed39aa 100644 --- a/src/Language/PureScript/InternedText.hs +++ b/src/Language/PureScript/InternedText.hs @@ -28,7 +28,7 @@ interner :: MVar (M.Map Text InternedName, IM.IntMap Text, InternedName) interner = unsafePerformIO $ newMVar (M.empty, IM.empty, InternedName 0) intern :: Text -> InternedName -intern s = unsafePerformIO $ do +intern s = s `seq` unsafePerformIO $ do modifyMVar interner $ \(m, im, next) -> case M.lookup s m of Just i -> pure ((m, im, next), i) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 5e3215e396..db5f418f95 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -158,17 +158,28 @@ coerceOpName = OpName . runOpName -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- -newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text } - deriving (Show, Eq, Ord, Generic) +newtype ProperName (a :: ProperNameType) = ProperName { unProperName :: InternedName } + deriving (Eq, Ord, Generic) + deriving newtype (NFData) + +properNameFromString :: Text -> ProperName a +properNameFromString = ProperName . intern + +runProperName :: ProperName a -> Text +runProperName (ProperName n) = unintern n + +instance Show (ProperName a) where + show (ProperName i) = "" -instance NFData (ProperName a) -instance Serialise (ProperName a) +instance Serialise (ProperName a) where + encode (ProperName n) = encode (unintern n) + decode = ProperName . intern <$> decode instance ToJSON (ProperName a) where toJSON = toJSON . runProperName instance FromJSON (ProperName a) where - parseJSON = fmap ProperName . parseJSON + parseJSON = fmap (ProperName . intern) . parseJSON -- | -- The closed set of proper name types. @@ -185,7 +196,7 @@ data ProperNameType -- classes have been desugared. -- coerceProperName :: ProperName a -> ProperName b -coerceProperName = ProperName . runProperName +coerceProperName = ProperName . unProperName -- | -- Module names diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index 20de0ed9e2..d0a1c8b819 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -28,7 +28,7 @@ import Data.Text qualified as T import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (tyFunction, tyRecord) -import Language.PureScript.Names (OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified, coerceProperName, disqualify, showQualified) +import Language.PureScript.Names (OpName(..), OpNameType(..), ProperName(..), runProperName, ProperNameType(..), Qualified, coerceProperName, disqualify, showQualified) import Language.PureScript.Pretty.Common (before, objectKeyRequiresQuoting) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), Type(..), TypeVarVisibility(..), WildcardData(..), eqType, rowToSortedList, typeVarVisibilityPrefix) import Language.PureScript.PSString (PSString, prettyPrintString, decodeString) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 4d5a5ec604..c4d4b955c3 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -18,7 +18,7 @@ import Data.Text qualified as T import Language.PureScript.AST (AssocList(..), Binder(..), CaseAlternative(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), Literal(..), PathNode(..), PathTree(..), TypeDeclarationData(..), pattern ValueDecl, WhereProvenance(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (OpName(..), ProperName(..), Qualified(..), disqualify, runModuleName, showIdent) +import Language.PureScript.Names (OpName(..), Qualified(..), disqualify, runModuleName, showIdent, runProperName) import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT) import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey) import Language.PureScript.Types (Constraint(..)) diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 3b4c019521..9ef751e130 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -13,7 +13,7 @@ import Language.PureScript.Constants.Libs qualified as Libs import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), NameKind(..)) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage') -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent, runProperName) import Language.PureScript.PSString (mkString) import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString) import Language.PureScript.TypeChecker (checkNewtype) diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 502a3dc05d..dcd662f8a5 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -23,7 +23,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>)) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames) import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts) @@ -279,10 +279,10 @@ deriveOrd utc = do orderingMod = ModuleName "Data.Ordering" orderingCtor :: Text -> Expr - orderingCtor = mkCtor orderingMod . ProperName + orderingCtor = mkCtor orderingMod . properNameFromString orderingBinder :: Text -> Binder - orderingBinder name = mkCtorBinder orderingMod (ProperName name) [] + orderingBinder name = mkCtorBinder orderingMod (properNameFromString name) [] ordCompare :: Expr -> Expr -> Expr ordCompare = App . App (mkRef Libs.I_compare) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7895e541b1..225f2737fb 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -39,7 +39,7 @@ import Language.PureScript.AST.Declarations (UnknownsHint(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName) import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds) import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation) import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 20076c39bb..d0e707ec5f 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -51,7 +51,7 @@ import Data.Traversable (for) import Language.PureScript.Crash (HasCallStack, internalError) import Language.PureScript.Environment qualified as E import Language.PureScript.Errors -import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified, runProperName, properNameFromString) import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) @@ -190,7 +190,7 @@ inferKind = \tyToInfer -> pure (ty, E.tyInt $> ann) ty@(TypeVar ann v) -> do moduleName <- unsafeCheckCurrentModule - kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ ProperName v) + kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ properNameFromString v) pure (ty, kind $> ann) ty@(Skolem ann _ mbK _ _) -> do kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK @@ -231,7 +231,7 @@ inferKind = \tyToInfer -> kind <- case mbKind of Just k -> replaceAllTypeSynonyms =<< checkIsSaturatedType k Nothing -> freshKind (fst ann) - (ty', unks) <- bindLocalTypeVariables moduleName [(ProperName arg, kind)] $ do + (ty', unks) <- bindLocalTypeVariables moduleName [(properNameFromString arg, kind)] $ do ty' <- apply =<< checkIsSaturatedType ty unks <- unknownsWithKinds . IS.toList $ unknowns ty' pure (ty', unks) @@ -529,7 +529,7 @@ elaborateKind = \case ($> ann) <$> apply kind TypeVar ann a -> do moduleName <- unsafeCheckCurrentModule - kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ ProperName a) + kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ properNameFromString a) pure (kind $> ann) (Skolem ann _ mbK _ _) -> do kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK @@ -643,10 +643,10 @@ inferDataDeclaration inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind - bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do + bindLocalTypeVariables moduleName (first properNameFromString . snd <$> sigBinders) $ do tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType subsumesKind (foldr ((E.-:>) . snd) E.kindType tyArgs') tyKind' - bindLocalTypeVariables moduleName (first ProperName <$> tyArgs') $ do + bindLocalTypeVariables moduleName (first properNameFromString <$> tyArgs') $ do let tyCtorName = srcTypeConstructor $ mkQualified tyName moduleName tyCtor = foldl (\ty -> srcKindApp ty . srcTypeVar . fst . snd) tyCtorName sigBinders tyCtor' = foldl (\ty -> srcTypeApp ty . srcTypeVar . fst) tyCtor tyArgs' @@ -695,11 +695,11 @@ inferTypeSynonym inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind - bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do + bindLocalTypeVariables moduleName (first properNameFromString . snd <$> sigBinders) $ do kindRes <- freshKind (fst ann) tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType unifyKinds tyKind' $ foldr ((E.-:>) . snd) kindRes tyArgs' - bindLocalTypeVariables moduleName (first ProperName <$> tyArgs') $ do + bindLocalTypeVariables moduleName (first properNameFromString <$> tyArgs') $ do tyBodyAndKind <- traverse apply =<< inferKind tyBody instantiateKind tyBodyAndKind =<< apply kindRes @@ -812,10 +812,10 @@ inferClassDeclaration inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = do clsKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ coerceProperName clsName) let (sigBinders, clsKind') = fromJust . completeBinderList $ clsKind - bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do + bindLocalTypeVariables moduleName (first properNameFromString. snd <$> sigBinders) $ do clsArgs' <- for clsArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType unifyKinds clsKind' $ foldr ((E.-:>) . snd) E.kindConstraint clsArgs' - bindLocalTypeVariables moduleName (first ProperName <$> clsArgs') $ do + bindLocalTypeVariables moduleName (first properNameFromString <$> clsArgs') $ do (clsArgs',,) <$> for superClasses checkConstraint <*> for decls checkClassMemberDeclaration @@ -886,7 +886,7 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do let ty = foldl (TypeApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) args tyWithConstraints = foldr srcConstrainedType ty constraints freeVars = freeTypeVariables tyWithConstraints - freeVarsDict <- for freeVars $ \v -> (ProperName v,) <$> freshKind (fst ann) + freeVarsDict <- for freeVars $ \v -> (properNameFromString v,) <$> freshKind (fst ann) bindLocalTypeVariables moduleName freeVarsDict $ do ty' <- checkKind ty E.kindConstraint constraints' <- for constraints checkConstraint diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 831c629d9b..729308ae7c 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -24,7 +24,7 @@ import Data.List.NonEmpty qualified as NEL import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..)) import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition) -import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName) +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString) import Language.PureScript.Pretty.Types (prettyPrintType) import Language.PureScript.Pretty.Values (prettyPrintValue) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) @@ -175,9 +175,9 @@ withScopedTypeVars withScopedTypeVars mn ks ma = do orig <- get forM_ ks $ \(name, _) -> - when (Qualified (ByModuleName mn) (ProperName name) `M.member` types (checkEnv orig)) $ + when (Qualified (ByModuleName mn) (properNameFromString name) `M.member` types (checkEnv orig)) $ tell . errorMessage $ ShadowedTypeVar name - bindTypes (M.fromList (map (\(name, k) -> (Qualified (ByModuleName mn) (ProperName name), (k, ScopedTypeVar))) ks)) ma + bindTypes (M.fromList (map (\(name, k) -> (Qualified (ByModuleName mn) (properNameFromString name), (k, ScopedTypeVar))) ks)) ma withErrorMessageHint :: (MonadState CheckState m, MonadError MultipleErrors m) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 6fe4cbf117..e25f470297 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -50,7 +50,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent, properNameFromString, runProperName) import Language.PureScript.TypeChecker.Deriving (deriveInstance) import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) @@ -776,16 +776,16 @@ check' val (ForAll ann vis ident mbK ty _) = do -- an undefined type variable that happens to clash with the variable we -- want to skolemize. This can happen due to synonym expansion (see 2542). skVal - | Just _ <- M.lookup (Qualified (byMaybeModuleName mn) (ProperName ident)) $ types env = + | Just _ <- M.lookup (Qualified (byMaybeModuleName mn) (properNameFromString ident)) $ types env = skolemizeTypesInValue ss ident mbK sko scope val | otherwise = val val' <- tvToExpr <$> check skVal sk return $ TypedValue' True val' (ForAll ann vis ident mbK ty (Just scope)) -check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ (ProperName className)) _ _ _) ty) = do +check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ className) _ _ _) ty) = do TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls -- An empty class dictionary is never used; see code in `TypeChecker.Entailment` -- that wraps empty dictionary solutions in `Unused`. - dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> className) + dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> runProperName className) dicts <- newDictionaries [] (Qualified ByNullSourcePos dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue' True (Abs (VarBinder nullSourceSpan dictName) (tvToExpr val')) t diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs index 593e8c1a8d..041ce80ac4 100644 --- a/src/Language/PureScript/TypeClassDictionaries.hs +++ b/src/Language/PureScript/TypeClassDictionaries.hs @@ -7,7 +7,7 @@ import Control.DeepSeq (NFData) import Data.Text (Text, pack) import Language.PureScript.AST.Declarations.ChainId (ChainId) -import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify) +import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, disqualify, runProperName) import Language.PureScript.Types (SourceConstraint, SourceType) -- From 16fa18b53d01eec1f7fa061a49d2cbdc31a7b45b Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Sat, 10 May 2025 08:42:08 +0000 Subject: [PATCH 03/19] generalise intern --- src/Language/PureScript/InternedText.hs | 17 +++++++++++---- src/Language/PureScript/Names.hs | 29 ++++++++++++------------- 2 files changed, 27 insertions(+), 19 deletions(-) diff --git a/src/Language/PureScript/InternedText.hs b/src/Language/PureScript/InternedText.hs index d8e4ed39aa..314f732d55 100644 --- a/src/Language/PureScript/InternedText.hs +++ b/src/Language/PureScript/InternedText.hs @@ -3,6 +3,8 @@ module Language.PureScript.InternedText , intern , unintern , IsString (..) + , internText + , uninternText ) where import Prelude @@ -20,14 +22,20 @@ newtype InternedName = InternedName Int deriving newtype (NFData, Eq, Ord) instance IsString InternedName where - fromString s = intern (fromString s) + fromString s = intern (fromString s :: Text) -- Global state {-# NOINLINE interner #-} -interner :: MVar (M.Map Text InternedName, IM.IntMap Text, InternedName) +interner :: MVar (M.Map a InternedName, IM.IntMap a, InternedName) interner = unsafePerformIO $ newMVar (M.empty, IM.empty, InternedName 0) -intern :: Text -> InternedName +internText :: Text -> InternedName +internText = intern + +uninternText :: InternedName -> Text +uninternText = unintern + +intern :: Ord a => a -> InternedName intern s = s `seq` unsafePerformIO $ do modifyMVar interner $ \(m, im, next) -> case M.lookup s m of @@ -38,10 +46,11 @@ intern s = s `seq` unsafePerformIO $ do in pure ((M.insert s i m, IM.insert ii s im, next'), i) -unintern :: HasCallStack => InternedName -> Text +unintern :: HasCallStack => InternedName -> a unintern (InternedName i) = unsafePerformIO $ do (_, im, _) <- readMVar interner case IM.lookup i im of Just s -> pure s Nothing -> error $ "Unknown interned name: " ++ show i + diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index db5f418f95..fbd5be91f2 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -22,8 +22,7 @@ import Data.Text qualified as T import Data.Int (Int64) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) -import Language.PureScript.InternedText (InternedName, unintern, intern) -import GHC.Stack (HasCallStack) +import Language.PureScript.InternedText (InternedName, uninternText, internText) -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -95,7 +94,7 @@ data Ident -- | UnusedIdent -- | - -- A generated name used only for internal transformations + -- A generated name used only for internTextal transformations -- | InternalIdent !InternalIdentData deriving (Show, Eq, Ord, Generic) @@ -163,23 +162,23 @@ newtype ProperName (a :: ProperNameType) = ProperName { unProperName :: Interned deriving newtype (NFData) properNameFromString :: Text -> ProperName a -properNameFromString = ProperName . intern +properNameFromString = ProperName . internText runProperName :: ProperName a -> Text -runProperName (ProperName n) = unintern n +runProperName (ProperName n) = uninternText n instance Show (ProperName a) where - show (ProperName i) = "" + show (ProperName i) = "" instance Serialise (ProperName a) where - encode (ProperName n) = encode (unintern n) - decode = ProperName . intern <$> decode + encode (ProperName n) = encode (uninternText n) + decode = ProperName . internText <$> decode instance ToJSON (ProperName a) where toJSON = toJSON . runProperName instance FromJSON (ProperName a) where - parseJSON = fmap (ProperName . intern) . parseJSON + parseJSON = fmap (ProperName . internText) . parseJSON -- | -- The closed set of proper name types. @@ -205,19 +204,19 @@ newtype ModuleName = ModuleName InternedName deriving (Show, Eq, Ord, Generic) instance Serialise ModuleName where - encode (ModuleName i) = encode (unintern i) - decode = ModuleName . intern <$> decode + encode (ModuleName i) = encode (uninternText i) + decode = ModuleName . internText <$> decode instance NFData ModuleName -runModuleName :: HasCallStack => ModuleName -> Text -runModuleName (ModuleName name) = unintern name +runModuleName :: ModuleName -> Text +runModuleName (ModuleName name) = uninternText name moduleNameFromString :: Text -> ModuleName -moduleNameFromString = ModuleName . intern +moduleNameFromString = ModuleName . internText isBuiltinModuleName :: ModuleName -> Bool -isBuiltinModuleName (ModuleName mn') = let mn = unintern mn' in mn == "Prim" || "Prim." `T.isPrefixOf` mn +isBuiltinModuleName (ModuleName mn') = let mn = uninternText mn' in mn == "Prim" || "Prim." `T.isPrefixOf` mn data QualifiedBy = BySourcePos SourcePos From 8889163c4d83b7d66f6492dd1f8c2fb046b0ed33 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Sat, 10 May 2025 20:29:59 +0000 Subject: [PATCH 04/19] PSString interning --- purescript.cabal | 5 +- src/Language/PureScript/InternedText.hs | 56 -------------- src/Language/PureScript/Interner.hs | 98 +++++++++++++++++++++++++ src/Language/PureScript/Names.hs | 8 +- src/Language/PureScript/PSString.hs | 39 +++++++--- tests/Language/PureScript/Ide/Test.hs | 12 +-- tests/TestAst.hs | 6 +- 7 files changed, 143 insertions(+), 81 deletions(-) delete mode 100644 src/Language/PureScript/InternedText.hs create mode 100644 src/Language/PureScript/Interner.hs diff --git a/purescript.cabal b/purescript.cabal index 7838188504..837b42f271 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -169,7 +169,8 @@ common defaults clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, -- unordered-containers, - -- hashable, + hashable, + random, cryptonite ==0.30.*, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, @@ -342,7 +343,7 @@ library Language.PureScript.Make.Monad Language.PureScript.ModuleDependencies Language.PureScript.Names - Language.PureScript.InternedText + Language.PureScript.Interner Language.PureScript.Options Language.PureScript.Pretty Language.PureScript.Pretty.Common diff --git a/src/Language/PureScript/InternedText.hs b/src/Language/PureScript/InternedText.hs deleted file mode 100644 index 314f732d55..0000000000 --- a/src/Language/PureScript/InternedText.hs +++ /dev/null @@ -1,56 +0,0 @@ -module Language.PureScript.InternedText - ( InternedName - , intern - , unintern - , IsString (..) - , internText - , uninternText - ) where - -import Prelude -import Control.Concurrent.MVar -import Data.Map.Strict qualified as M -import Data.IntMap.Strict qualified as IM -import System.IO.Unsafe (unsafePerformIO) -import Data.Text (Text) -import Data.String (IsString(..)) -import Control.DeepSeq (NFData) -import GHC.Stack (HasCallStack) - -newtype InternedName = InternedName Int - deriving (Show) - deriving newtype (NFData, Eq, Ord) - -instance IsString InternedName where - fromString s = intern (fromString s :: Text) - --- Global state -{-# NOINLINE interner #-} -interner :: MVar (M.Map a InternedName, IM.IntMap a, InternedName) -interner = unsafePerformIO $ newMVar (M.empty, IM.empty, InternedName 0) - -internText :: Text -> InternedName -internText = intern - -uninternText :: InternedName -> Text -uninternText = unintern - -intern :: Ord a => a -> InternedName -intern s = s `seq` unsafePerformIO $ do - modifyMVar interner $ \(m, im, next) -> - case M.lookup s m of - Just i -> pure ((m, im, next), i) - Nothing -> - let i@(InternedName ii) = next - next' = InternedName (ii + 1) - in pure ((M.insert s i m, IM.insert ii s im, next'), i) - - -unintern :: HasCallStack => InternedName -> a -unintern (InternedName i) = unsafePerformIO $ do - (_, im, _) <- readMVar interner - case IM.lookup i im of - Just s -> pure s - Nothing -> error $ "Unknown interned name: " ++ show i - - diff --git a/src/Language/PureScript/Interner.hs b/src/Language/PureScript/Interner.hs new file mode 100644 index 0000000000..00d9823449 --- /dev/null +++ b/src/Language/PureScript/Interner.hs @@ -0,0 +1,98 @@ +module Language.PureScript.Interner + ( Interner + , Interned + , intern + , unintern + , internText + , uninternText + , psStringInterner + , textInterner + , internPSString + , uninternPSString + ) where + +import Prelude +import Control.Concurrent.MVar +import Data.Map.Strict qualified as M +import Data.IntMap.Strict qualified as IM +import System.IO.Unsafe (unsafePerformIO) +import Data.Text (Text) +import Data.Word (Word16) +import Control.DeepSeq (NFData, deepseq) +import Data.String (IsString(..)) +import Data.Hashable (Hashable, hash, hashWithSalt) +import Data.Vector.Unboxed qualified as VU +import System.Random (randomIO) + +-- | The opaque interned identifier +newtype Interned = Interned Int + deriving (Eq, Ord, NFData) + + +instance IsString Interned where + fromString s = internText (fromString s) + +instance Show Interned where + show (Interned i) = "" + + +-- | A reusable interner structure +-- param 'k' is the key (e.g., Text, Vector Word16) +data Interner k = Interner + { internerMap :: !(M.Map k Interned) + , reverseMap :: !(IM.IntMap k) + , internerId :: Int + } + deriving (Eq, Ord, Show) + +type InternerVar k = MVar (Interner k) + +-- | Intern a key and get its Interned ID +intern :: (Hashable k, Ord k, NFData k) => InternerVar k -> k -> Interned +intern var k = unsafePerformIO $ do + k `deepseq` modifyMVar var $ \st -> do + -- Check if the key is already interned + case M.lookup k (internerMap st) of + Just i -> pure (st, i) + Nothing -> + let h = hash k + i = Interned h + m' = M.insert k i (internerMap st) + im' = IM.insert h k (reverseMap st) + in pure (st { internerMap = m', reverseMap = im' }, i) + +-- | Reverse an Interned ID back to the original key +unintern :: InternerVar k -> Interned -> k +unintern var (Interned i) = unsafePerformIO $ do + Interner { reverseMap, internerId } <- readMVar var + case IM.lookup i reverseMap of + Just v -> pure v + Nothing -> error $ "Unknown interned ID: " ++ show i <> " interner: " <> show internerId + +{-# NOINLINE textInterner #-} +textInterner :: InternerVar Text +textInterner = unsafePerformIO $ randomIO >>= \r -> newMVar $ Interner M.empty IM.empty r + + +internText :: Text -> Interned +internText !t = intern textInterner t + +uninternText :: Interned -> Text +uninternText !i = unintern textInterner i + + +{-# NOINLINE psStringInterner #-} +psStringInterner :: InternerVar [Word16] +psStringInterner = unsafePerformIO $ randomIO >>= \r -> newMVar $ Interner M.empty IM.empty r + +newtype Word16Vec = Word16Vec { unVector :: VU.Vector Word16 } + deriving (Eq, Ord, NFData, Show) + +instance Hashable Word16Vec where + hashWithSalt salt (Word16Vec vec) = hashWithSalt salt (VU.toList vec) + +internPSString :: [Word16] -> Interned +internPSString !wa = intern psStringInterner wa + +uninternPSString :: Interned -> [Word16] +uninternPSString !i = unintern psStringInterner i diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index fbd5be91f2..2738f8d120 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -22,7 +22,7 @@ import Data.Text qualified as T import Data.Int (Int64) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) -import Language.PureScript.InternedText (InternedName, uninternText, internText) +import Language.PureScript.Interner (Interned, uninternText, internText) -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -157,7 +157,7 @@ coerceOpName = OpName . runOpName -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- -newtype ProperName (a :: ProperNameType) = ProperName { unProperName :: InternedName } +newtype ProperName (a :: ProperNameType) = ProperName { unProperName :: Interned } deriving (Eq, Ord, Generic) deriving newtype (NFData) @@ -200,7 +200,7 @@ coerceProperName = ProperName . unProperName -- | -- Module names -- -newtype ModuleName = ModuleName InternedName +newtype ModuleName = ModuleName Interned deriving (Show, Eq, Ord, Generic) instance Serialise ModuleName where @@ -216,7 +216,7 @@ moduleNameFromString :: Text -> ModuleName moduleNameFromString = ModuleName . internText isBuiltinModuleName :: ModuleName -> Bool -isBuiltinModuleName (ModuleName mn') = let mn = uninternText mn' in mn == "Prim" || "Prim." `T.isPrefixOf` mn +isBuiltinModuleName mn' = let mn = runModuleName mn' in mn == "Prim" || "Prim." `T.isPrefixOf` mn data QualifiedBy = BySourcePos SourcePos diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 2ceb481181..5001c2173a 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE InstanceSigs #-} module Language.PureScript.PSString ( PSString , toUTF16CodeUnits @@ -11,8 +12,8 @@ module Language.PureScript.PSString import Prelude import GHC.Generics (Generic) -import Codec.Serialise (Serialise) -import Control.DeepSeq (NFData) +import Codec.Serialise qualified as Codec +import Control.DeepSeq (NFData (..)) import Control.Exception (try, evaluate) import Control.Applicative ((<|>)) import Data.Char qualified as Char @@ -33,6 +34,7 @@ import Numeric (showHex) import System.IO.Unsafe (unsafePerformIO) import Data.Aeson qualified as A import Data.Aeson.Types qualified as A +import Language.PureScript.Interner (Interned, uninternPSString, internPSString) -- | -- Strings in PureScript are sequences of UTF-16 code units, which do not @@ -48,15 +50,32 @@ import Data.Aeson.Types qualified as A -- strings where that would be safe (i.e. when there are no lone surrogates), -- and arrays of UTF-16 code units (integers) otherwise. -- -newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } - deriving (Eq, Ord, Semigroup, Monoid, Generic) - -instance NFData PSString -instance Serialise PSString +newtype PSString = PSString { unPSString :: Interned } + deriving (Eq, Ord, NFData, Generic) instance Show PSString where show = show . codePoints +toUTF16CodeUnits :: PSString -> [Word16] +toUTF16CodeUnits (PSString ps) = uninternPSString ps + +mkPSString :: [Word16] -> PSString +mkPSString ps = PSString $ internPSString ps + + +instance Semigroup PSString where + PSString a <> PSString b = PSString $ internPSString (uninternPSString a <> uninternPSString b) + +instance Monoid PSString where + mempty = PSString (internPSString []) + mappend = (<>) + +instance Codec.Serialise PSString where + encode (PSString s) = Codec.encode (uninternPSString s) + decode = mkPSString <$> Codec.decode + + + -- | -- Decode a PSString to a String, representing any lone surrogates as the -- reserved code point with that index. Warning: if there are any lone @@ -66,7 +85,7 @@ instance Show PSString where -- we do not export it. -- codePoints :: PSString -> String -codePoints = map (either (Char.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 @@ -116,7 +135,7 @@ decodeString = hush . decodeEither . BS.pack . concatMap unpair . toUTF16CodeUni hush = either (const Nothing) Just instance IsString PSString where - fromString a = PSString $ concatMap encodeUTF16 a + fromString a = mkPSString $ concatMap encodeUTF16 a where surrogates :: Char -> (Word16, Word16) surrogates c = (toWord (h + 0xD800), toWord (l + 0xDC00)) @@ -138,7 +157,7 @@ instance A.FromJSON PSString where where jsonString = fromString <$> A.parseJSON a - arrayOfCodeUnits = PSString <$> parseArrayOfCodeUnits a + arrayOfCodeUnits = mkPSString <$> parseArrayOfCodeUnits a parseArrayOfCodeUnits :: A.Value -> A.Parser [Word16] parseArrayOfCodeUnits = A.withArray "array of UTF-16 code units" (traverse parseCodeUnit . V.toList) diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index 17998d63d1..dcb3cb2ce2 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -60,23 +60,23 @@ ideValue :: Text -> Maybe P.SourceType -> IdeDeclarationAnn ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty))) ideType :: Text -> Maybe P.SourceType -> [(P.ProperName 'P.ConstructorName, P.SourceType)] -> IdeDeclarationAnn -ideType pn ki dtors = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki) dtors)) +ideType pn ki dtors = ida (IdeDeclType (IdeType (P.properNameFromString pn) (fromMaybe P.kindType ki) dtors)) ideSynonym :: Text -> Maybe P.SourceType -> Maybe P.SourceType -> IdeDeclarationAnn -ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) (fromMaybe P.tyString ty) (fromMaybe P.kindType kind))) +ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.properNameFromString pn) (fromMaybe P.tyString ty) (fromMaybe P.kindType kind))) ideTypeClass :: Text -> P.SourceType -> [IdeInstance] -> IdeDeclarationAnn -ideTypeClass pn kind instances = ida (IdeDeclTypeClass (IdeTypeClass (P.ProperName pn) kind instances)) +ideTypeClass pn kind instances = ida (IdeDeclTypeClass (IdeTypeClass (P.properNameFromString pn) kind instances)) ideDtor :: Text -> Text -> Maybe P.SourceType -> IdeDeclarationAnn -ideDtor pn tn ty = ida (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName pn) (P.ProperName tn) (fromMaybe P.tyString ty))) +ideDtor pn tn ty = ida (IdeDeclDataConstructor (IdeDataConstructor (P.properNameFromString pn) (P.properNameFromString tn) (fromMaybe P.tyString ty))) ideValueOp :: Text -> P.Qualified (Either Text Text) -> Integer -> Maybe P.Associativity -> Maybe P.SourceType -> IdeDeclarationAnn ideValueOp opName ident precedence assoc t = ida (IdeDeclValueOperator (IdeValueOperator (P.OpName opName) - (bimap P.Ident P.ProperName <$> ident) + (bimap P.Ident P.properNameFromString <$> ident) precedence (fromMaybe P.Infix assoc) t)) @@ -86,7 +86,7 @@ ideTypeOp opName ident precedence assoc k = ida (IdeDeclTypeOperator (IdeTypeOperator (P.OpName opName) - (P.ProperName <$> ident) + (P.properNameFromString <$> ident) precedence (fromMaybe P.Infix assoc) k)) diff --git a/tests/TestAst.hs b/tests/TestAst.hs index bb2e880443..1ee48ed180 100644 --- a/tests/TestAst.hs +++ b/tests/TestAst.hs @@ -10,7 +10,7 @@ import Test.Hspec (Spec, describe, it) import Test.QuickCheck (Arbitrary(..), Gen, Property, Testable, counterexample, forAllShrink, subterms, (===)) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..)) +import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), properNameFromString, ProperNameType(..), Qualified(..)) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (Constraint, ConstraintData, SkolemScope(..), Type(..), TypeVarVisibility(..), WildcardData, annForType, everythingOnTypes, everythingWithContextOnTypes, everywhereOnTypes, everywhereOnTypesM, everywhereOnTypesTopDownM, getAnnForType) @@ -54,8 +54,8 @@ genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where :+ Label <$> genPSString :+ genPSString :+ genQualified (OpName @'TypeOpName) - :+ genQualified (ProperName @'ClassName) - :+ genQualified (ProperName @'TypeName) + :+ genQualified (properNameFromString @'ClassName) + :+ genQualified (properNameFromString @'TypeName) :+ genSkolemScope :+ maybeOf genSkolemScope :+ genText From 71eafabf5f4bc0c189d32e5027de018a602b4c80 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Sun, 11 May 2025 16:07:49 +0000 Subject: [PATCH 05/19] Qualified by hash --- src/Language/PureScript/AST/Declarations.hs | 12 ++-- src/Language/PureScript/AST/SourcePos.hs | 3 +- src/Language/PureScript/AST/Utils.hs | 12 ++-- src/Language/PureScript/CST/Convert.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 12 ++-- src/Language/PureScript/Constants/Libs.hs | 2 +- src/Language/PureScript/Constants/TH.hs | 29 +++++--- src/Language/PureScript/CoreFn/CSE.hs | 10 +-- src/Language/PureScript/CoreFn/Desugar.hs | 14 ++-- src/Language/PureScript/CoreFn/FromJSON.hs | 6 +- src/Language/PureScript/CoreFn/Laziness.hs | 12 ++-- src/Language/PureScript/CoreFn/ToJSON.hs | 2 +- src/Language/PureScript/Docs/Convert.hs | 6 +- .../PureScript/Docs/Convert/ReExports.hs | 2 +- .../PureScript/Docs/Convert/Single.hs | 10 +-- src/Language/PureScript/Docs/Render.hs | 4 +- .../PureScript/Docs/RenderedCode/Types.hs | 10 +-- src/Language/PureScript/Docs/Types.hs | 4 +- src/Language/PureScript/Errors.hs | 52 +++++++------- src/Language/PureScript/Externs.hs | 24 +++---- src/Language/PureScript/Hierarchy.hs | 2 +- src/Language/PureScript/Ide/Error.hs | 2 +- src/Language/PureScript/Ide/State.hs | 8 +-- src/Language/PureScript/Ide/Usage.hs | 4 +- src/Language/PureScript/Interactive.hs | 2 +- src/Language/PureScript/Interactive/Module.hs | 6 +- .../PureScript/Interactive/Printer.hs | 8 +-- src/Language/PureScript/Interner.hs | 6 ++ src/Language/PureScript/Linter.hs | 4 +- src/Language/PureScript/Linter/Exhaustive.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 6 +- src/Language/PureScript/Make/ExternsDiff.hs | 8 +-- src/Language/PureScript/Names.hs | 68 +++++++++++++------ src/Language/PureScript/Pretty/Values.hs | 2 +- src/Language/PureScript/Renamer.hs | 6 +- src/Language/PureScript/Sugar/Accessor.hs | 4 +- src/Language/PureScript/Sugar/AdoNotation.hs | 10 +-- .../PureScript/Sugar/BindingGroups.hs | 18 ++--- .../PureScript/Sugar/CaseDeclarations.hs | 10 +-- src/Language/PureScript/Sugar/DoNotation.hs | 8 +-- src/Language/PureScript/Sugar/Names.hs | 20 +++--- src/Language/PureScript/Sugar/Names/Env.hs | 12 ++-- .../PureScript/Sugar/Names/Exports.hs | 6 +- .../PureScript/Sugar/Names/Imports.hs | 8 +-- .../PureScript/Sugar/ObjectWildcards.hs | 4 +- src/Language/PureScript/Sugar/Operators.hs | 38 +++++------ .../PureScript/Sugar/Operators/Binders.hs | 2 +- .../PureScript/Sugar/Operators/Expr.hs | 2 +- .../PureScript/Sugar/Operators/Types.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 12 ++-- .../PureScript/Sugar/TypeClasses/Deriving.hs | 14 ++-- src/Language/PureScript/TypeChecker.hs | 50 +++++++------- .../PureScript/TypeChecker/Deriving.hs | 16 ++--- .../PureScript/TypeChecker/Entailment.hs | 14 ++-- .../TypeChecker/Entailment/Coercible.hs | 6 +- src/Language/PureScript/TypeChecker/Kinds.hs | 14 ++-- src/Language/PureScript/TypeChecker/Monad.hs | 20 +++--- src/Language/PureScript/TypeChecker/Roles.hs | 8 +-- .../PureScript/TypeChecker/TypeSearch.hs | 6 +- src/Language/PureScript/TypeChecker/Types.hs | 20 +++--- tests/Language/PureScript/Ide/FilterSpec.hs | 4 +- tests/Language/PureScript/Ide/ImportsSpec.hs | 2 +- .../Language/PureScript/Ide/SourceFileSpec.hs | 8 +-- tests/Language/PureScript/Ide/StateSpec.hs | 8 +-- tests/TestAst.hs | 4 +- tests/TestCoreFn.hs | 24 +++---- tests/TestDocs.hs | 5 +- tests/TestHierarchy.hs | 2 +- 68 files changed, 392 insertions(+), 351 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 7184cbb812..150ca42c12 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -27,7 +27,7 @@ import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Types (SourceConstraint, SourceType) import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), toMaybeModuleName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), toMaybeModuleName, mkQualified_) import Language.PureScript.Roles (Role) import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Comments (Comment) @@ -141,7 +141,7 @@ getModuleDeclarations (Module _ _ _ declarations _) = declarations -- (See #2197) -- addDefaultImport :: Qualified ModuleName -> Module -> Module -addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) = +addDefaultImport (Qualified toImportAs toImport _) m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs' : decls) exps where @@ -161,8 +161,8 @@ importPrim = let primModName = C.M_Prim in - addDefaultImport (Qualified (ByModuleName primModName) primModName) - . addDefaultImport (Qualified ByNullSourcePos primModName) + addDefaultImport (mkQualified_ (ByModuleName primModName) primModName) + . addDefaultImport (mkQualified_ ByNullSourcePos primModName) data NameSource = UserNamed | CompilerNamed deriving (Eq, Show, Generic, NFData, Serialise) @@ -856,8 +856,8 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDe isTrueExpr :: Expr -> Bool isTrueExpr (Literal _ (BooleanLiteral True)) = True -isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Prelude")) (Ident "otherwise"))) = True -isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Data.Boolean")) (Ident "otherwise"))) = True +isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Prelude")) (Ident "otherwise") _)) = True +isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Data.Boolean")) (Ident "otherwise") _)) = True isTrueExpr (TypedValue _ e _) = isTrueExpr e isTrueExpr (PositionedValue _ _ e) = isTrueExpr e isTrueExpr _ = False diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 262d44b6a1..fcb33f45c6 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -15,6 +15,7 @@ import Language.PureScript.Comments (Comment) import Data.Aeson qualified as A import Data.Text qualified as T import System.FilePath (makeRelative) +import Data.Hashable (Hashable) -- | Source annotation - position information and comments. type SourceAnn = (SourceSpan, [Comment]) @@ -25,7 +26,7 @@ data SourcePos = SourcePos -- ^ Line number , sourcePosColumn :: Int -- ^ Column number - } deriving (Show, Eq, Ord, Generic, NFData, Serialise) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise, Hashable) displaySourcePos :: SourcePos -> Text displaySourcePos sp = diff --git a/src/Language/PureScript/AST/Utils.hs b/src/Language/PureScript/AST/Utils.hs index d768a884fd..6e774d6625 100644 --- a/src/Language/PureScript/AST/Utils.hs +++ b/src/Language/PureScript/AST/Utils.hs @@ -3,7 +3,7 @@ module Language.PureScript.AST.Utils where import Protolude import Language.PureScript.AST (Binder(..), CaseAlternative, Expr(..), GuardedExpr, Literal, pattern MkUnguarded, nullSourceSpan) -import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName) +import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, mkQualified_) import Language.PureScript.Types (SourceType, Type(..)) lam :: Ident -> Expr -> Expr @@ -19,7 +19,7 @@ mkRef :: Qualified Ident -> Expr mkRef = Var nullSourceSpan mkVarMn :: Maybe ModuleName -> Ident -> Expr -mkVarMn mn = mkRef . Qualified (byMaybeModuleName mn) +mkVarMn mn = mkRef . mkQualified_ (byMaybeModuleName mn) mkVar :: Ident -> Expr mkVar = mkVarMn Nothing @@ -31,10 +31,10 @@ mkLit :: Literal Expr -> Expr mkLit = Literal nullSourceSpan mkCtor :: ModuleName -> ProperName 'ConstructorName -> Expr -mkCtor mn name = Constructor nullSourceSpan (Qualified (ByModuleName mn) name) +mkCtor mn name = Constructor nullSourceSpan (mkQualified_ (ByModuleName mn) name) mkCtorBinder :: ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder -mkCtorBinder mn name = ConstructorBinder nullSourceSpan (Qualified (ByModuleName mn) name) +mkCtorBinder mn name = ConstructorBinder nullSourceSpan (mkQualified_ (ByModuleName mn) name) unguarded :: Expr -> [GuardedExpr] unguarded e = [MkUnguarded e] @@ -47,13 +47,13 @@ data UnwrappedTypeConstructor = UnwrappedTypeConstructor } utcQTyCon :: UnwrappedTypeConstructor -> Qualified (ProperName 'TypeName) -utcQTyCon UnwrappedTypeConstructor{..} = Qualified (ByModuleName utcModuleName) utcTyCon +utcQTyCon UnwrappedTypeConstructor{..} = mkQualified_ (ByModuleName utcModuleName) utcTyCon unwrapTypeConstructor :: SourceType -> Maybe UnwrappedTypeConstructor unwrapTypeConstructor = go [] [] where go kargs args = \case - TypeConstructor _ (Qualified (ByModuleName mn) tyCon) -> Just (UnwrappedTypeConstructor mn tyCon kargs args) + TypeConstructor _ (Qualified (ByModuleName mn) tyCon _) -> Just (UnwrappedTypeConstructor mn tyCon kargs args) TypeApp _ ty arg -> go kargs (arg : args) ty KindApp _ ty karg -> go (karg : kargs) args ty _ -> Nothing diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index c51ebf170f..583bce04ca 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -90,7 +90,7 @@ moduleName = \case go ns = Just $ N.moduleNameFromString $ Text.intercalate "." ns qualified :: QualifiedName a -> N.Qualified a -qualified q = N.Qualified qb (qualName q) +qualified q = N.mkQualified_ qb (qualName q) where qb = maybe N.ByNullSourcePos N.ByModuleName $ qualModule q diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index f598fa6602..f963fa5d2f 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -263,7 +263,7 @@ moduleBindToJs mn = bindToJs guessEffects :: Expr Ann -> AST.InitializerEffects guessEffects = \case - Var _ (Qualified (BySourcePos _) _) -> NoEffects + Var _ (Qualified (BySourcePos _) _ _) -> NoEffects App (_, _, Just IsSyntheticApp) _ _ -> NoEffects _ -> UnknownEffects @@ -319,7 +319,7 @@ moduleBindToJs mn = bindToJs unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) unApp (App _ val arg) args = unApp val (arg : args) unApp other args = (other, args) - valueToJs' (Var (_, _, Just IsForeign) qi@(Qualified (ByModuleName mn') ident)) = + valueToJs' (Var (_, _, Just IsForeign) qi@(Qualified (ByModuleName mn') ident _)) = return $ if mn' == mn then foreignIdent ident else varToJs qi @@ -388,15 +388,15 @@ moduleBindToJs mn = bindToJs -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable. varToJs :: Qualified Ident -> AST - varToJs (Qualified (BySourcePos _) ident) = var ident + varToJs (Qualified (BySourcePos _) ident _) = var ident varToJs qual = qualifiedToJS id qual -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. qualifiedToJS :: (a -> Ident) -> Qualified a -> AST - qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a) = AST.Var Nothing . runIdent $ f a - qualifiedToJS f (Qualified (ByModuleName mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a - qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) + qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a _) = AST.Var Nothing . runIdent $ f a + qualifiedToJS f (Qualified (ByModuleName mn') a _) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a + qualifiedToJS f (Qualified _ a _) = AST.Var Nothing $ identToJs (f a) foreignIdent :: Ident -> AST foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing FFINamespace) diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index 0b44d3e408..831cd71493 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -276,4 +276,4 @@ $(TH.declare do ) pattern IsSymbolDict :: Qualified Ident -pattern IsSymbolDict = Qualified (ByModuleName M_Data_Symbol) (Ident "IsSymbol$Dict") +pattern IsSymbolDict = Qualified (ByModuleName M_Data_Symbol) (Ident "IsSymbol$Dict") (-7980125151384708176) diff --git a/src/Language/PureScript/Constants/TH.hs b/src/Language/PureScript/Constants/TH.hs index 2bc8a56d84..7430a8079e 100644 --- a/src/Language/PureScript/Constants/TH.hs +++ b/src/Language/PureScript/Constants/TH.hs @@ -73,9 +73,9 @@ import Control.Lens (over, _head) import Control.Monad.Trans.RWS (RWS, execRWS) import Control.Monad.Trans.Writer (Writer, execWriter) import Control.Monad.Writer.Class (tell) -import Data.String (String) -import Language.Haskell.TH (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL) -import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..)) +import Data.String (String, fromString) +import Language.Haskell.TH (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL, nameBase, Lit (IntegerL)) +import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString) -- | Generate pattern synonyms corresponding to the provided PureScript -- declarations. @@ -191,18 +191,29 @@ mkPrefixedName tag prefix = mkName . (tag <>) . camelAppend prefix -- 'TypeName -> M_Data_Foo -> "Function" -> "Foo" -> -- pattern FunctionFoo :: Qualified (ProperName 'TypeName) -- pattern FunctionFoo = Qualified (ByModuleName M_Data_Foo) (ProperName "Foo") + mkPnPat :: Q Type -> VarToDec -mkPnPat pnType mn prefix str = typedPatSyn (mkName $ cap prefix <> str) - [t| Qualified (ProperName $pnType) |] - [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str)) |] +mkPnPat pnType mn prefix str = do + let modNameStr = nameBase mn + -- Compute the hash + let hashValue = toInteger (hash (ByModuleName (moduleNameFromString (fromString modNameStr)))) + typedPatSyn (mkName $ cap prefix <> str) + [t| Qualified (ProperName $pnType) |] + [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str)) $(litP $ IntegerL hashValue) |] + -- M_Data_Foo -> "function" -> "foo" -> -- pattern I_functionFoo :: Qualified Ident -- pattern I_functionFoo = Qualified (ByModuleName M_Data_Foo) (Ident "foo") mkIdentDec :: VarToDec -mkIdentDec mn prefix str = typedPatSyn (mkPrefixedName "I_" prefix str) - [t| Qualified Ident |] - [p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) |] +mkIdentDec mn prefix str = do + let modNameStr = nameBase mn + -- Compute the hash + let hashValue = toInteger (hash (ByModuleName (moduleNameFromString (fromString modNameStr)))) + + typedPatSyn (mkPrefixedName "I_" prefix str) + [t| Qualified Ident |] + [p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) $(litP $ IntegerL hashValue) |] -- M_Data_Foo -> "function" -> "foo" -> -- pattern P_functionFoo :: forall a. (Eq a, IsString a) => (ModuleName, a) diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index a79bf5c78c..d6bb70786b 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -26,7 +26,7 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) import Language.PureScript.CoreFn.Meta (Meta(IsSyntheticApp)) import Language.PureScript.CoreFn.Traversals (everywhereOnValues, traverseCoreFn) import Language.PureScript.Environment (dictTypeName) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString, mkQualified_) import Language.PureScript.PSString (decodeString) -- | @@ -254,7 +254,7 @@ generateIdentFor d e = at d . non mempty . at e %%<~ \case -> decodedStr <> "IsSymbol" | otherwise -> nameHint v1 - Var _ (Qualified _ ident) + Var _ (Qualified _ ident _) | Ident name <- ident -> name | GenIdent (Just name) _ <- ident -> name Accessor _ prop _ @@ -270,7 +270,7 @@ nullAnn = (nullSourceSpan, [], Nothing) replaceLocals :: M.Map Ident (Expr Ann) -> [Bind Ann] -> [Bind Ann] replaceLocals m = if M.null m then identity else map f' where (f', g', _) = everywhereOnValues identity f identity - f e@(Var _ (Qualified _ ident)) = maybe e g' $ ident `M.lookup` m + f e@(Var _ (Qualified _ ident _)) = maybe e g' $ ident `M.lookup` m f e = e -- | @@ -292,7 +292,7 @@ floatExpr topLevelQB = \case let w' = w & (if isNew then newBindings %~ addToScope deepestScope [(ident, (_plurality, e))] else identity) & plurality .~ PluralityMap (M.singleton ident False) - pure (Var nullAnn (Qualified qb ident), w') + pure (Var nullAnn (mkQualified_ qb ident), w') (e, w) -> pure (e, w) -- | @@ -339,7 +339,7 @@ summarizeName => ModuleName -> Qualified Ident -> m () -summarizeName mn (Qualified mn' ident) = do +summarizeName mn (Qualified mn' ident _) = do m <- view bound let (s, bt) = fromMaybe (0, NonRecursive) $ diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 484ca67ee3..8718a3882e 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -23,7 +23,7 @@ import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, runProperName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, runProperName, mkQualified_) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST qualified as A @@ -65,7 +65,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = declToCoreFn :: A.Declaration -> [Bind Ann] declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ - Abs (ss, com, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] + Abs (ss, com, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ mkQualified_ ByNullSourcePos (Ident "x"))] where declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = @@ -74,7 +74,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = flip fmap ctors $ \ctorDecl -> let ctor = A.dataCtorName ctorDecl - (_, _, _, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) + (_, _, _, fields) = lookupConstructor env (mkQualified_ (ByModuleName mn) ctor) in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds @@ -113,7 +113,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = v1' = exprToCoreFn ss [] Nothing v1 v2' = exprToCoreFn ss [] Nothing v2 isDictCtor = \case - A.Constructor _ (Qualified _ name) -> isDictTypeName name + A.Constructor _ (Qualified _ name _) -> isDictTypeName name _ -> False isSynthetic = \case A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 @@ -168,9 +168,9 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = NullBinder (ss, com, Nothing) binderToCoreFn _ com (A.VarBinder ss name) = VarBinder (ss, com, Nothing) name - binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = + binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _ _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor - in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) + in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (mkQualified_ mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) binderToCoreFn _ com (A.NamedBinder ss name b) = NamedBinder (ss, com, Nothing) name (binderToCoreFn ss [] b) binderToCoreFn _ com (A.PositionedBinder ss com1 b) = @@ -214,7 +214,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = typeConstructor :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) -> (ModuleName, ProperName 'TypeName) - typeConstructor (Qualified (ByModuleName mn') _, (_, tyCtor, _, _)) = (mn', tyCtor) + typeConstructor (Qualified (ByModuleName mn') _ _, (_, tyCtor, _, _)) = (mn', tyCtor) typeConstructor _ = internalError "Invalid argument to typeConstructor" -- | Find module names from qualified references to values. This is used to diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 3057d4702c..783dad5da4 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -23,7 +23,7 @@ import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn (Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Meta(..), Module(..)) -import Language.PureScript.Names (Ident(..), ModuleName(..), properNameFromString, Qualified(..), QualifiedBy(..), unusedIdent, moduleNameFromString, ProperName) +import Language.PureScript.Names (Ident(..), ModuleName(..), properNameFromString, Qualified(..), QualifiedBy(..), unusedIdent, moduleNameFromString, ProperName, mkQualified_) import Language.PureScript.PSString (PSString) import Text.ParserCombinators.ReadP (readP_to_S) @@ -118,11 +118,11 @@ qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj qualifiedByModuleFromObj o = do mn <- o .: "moduleName" >>= moduleNameFromJSON i <- o .: "identifier" >>= withText "Ident" (return . f) - pure $ Qualified (ByModuleName mn) i + pure $ mkQualified_ (ByModuleName mn) i qualifiedBySourcePosFromObj o = do ss <- o .: "sourcePos" i <- o .: "identifier" >>= withText "Ident" (return . f) - pure $ Qualified (BySourcePos ss) i + pure $ mkQualified_ (BySourcePos ss) i moduleNameFromJSON :: Value -> Parser ModuleName moduleNameFromJSON v = moduleNameFromString . T.intercalate "." <$> listParser parseJSON v diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs index 9941fd41c5..b3ec183c91 100644 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -20,7 +20,7 @@ import Language.PureScript.AST.SourcePos (SourcePos(..), SourceSpan(..), nullSou import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.CoreFn (Ann, Bind, Expr(..), Literal(..), Meta(..), ssAnn, traverseCoreFn) import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, Qualified(..), QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, Qualified(..), QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName, mkQualified_) import Language.PureScript.PSString (mkString) -- This module is responsible for ensuring that the bindings in recursive @@ -432,7 +432,7 @@ applyLazinessTransform mn rawItems = let -- A B (keys) C (keys) D findReferences :: Expr Ann -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) findReferences = (getConst .) . onVarsWithDelayAndForce $ \delay force _ -> \case - Qualified qb ident | all (== mn) (toMaybeModuleName qb), Just i <- ident `S.lookupIndex` names + Qualified qb ident _ | all (== mn) (toMaybeModuleName qb), Just i <- ident `S.lookupIndex` names -> Const . IM.singleton delay . IM.singleton i $ coerceForce force _ -> Const IM.empty @@ -516,7 +516,7 @@ applyLazinessTransform mn rawItems = let Nothing -> pair Just m -> let rewriteExpr = (runIdentity .) . onVarsWithDelayAndForce $ \delay _ ann -> pure . \case - Qualified qb ident' | all (== mn) (toMaybeModuleName qb), any (all (>= Max delay) . getAp) $ ident' `M.lookup` m + Qualified qb ident' _ | all (== mn) (toMaybeModuleName qb), any (all (>= Max delay) . getAp) $ ident' `M.lookup` m -> makeForceCall ann ident' q -> Var ann q in (ident, rewriteExpr <$> item) @@ -531,8 +531,8 @@ applyLazinessTransform mn rawItems = let where nullAnn = ssAnn nullSourceSpan - runtimeLazy = Var nullAnn . Qualified ByNullSourcePos $ InternalIdent RuntimeLazyFactory - runFn3 = Var nullAnn . Qualified (ByModuleName C.M_Data_Function_Uncurried) . Ident $ C.S_runFn <> "3" + runtimeLazy = Var nullAnn . mkQualified_ ByNullSourcePos $ InternalIdent RuntimeLazyFactory + runFn3 = Var nullAnn . mkQualified_ (ByModuleName C.M_Data_Function_Uncurried) . Ident $ C.S_runFn <> "3" strLit = Literal nullAnn . StringLiteral . mkString lazifyIdent = \case @@ -545,7 +545,7 @@ applyLazinessTransform mn rawItems = let -- argument: the line number on which this reference is made. The runtime -- code uses this number to generate a message that identifies where the -- evaluation looped. - = App nullAnn (Var nullAnn . Qualified ByNullSourcePos $ lazifyIdent ident) + = App nullAnn (Var nullAnn . mkQualified_ ByNullSourcePos $ lazifyIdent ident) . Literal nullAnn . NumericLiteral . Left . toInteger . sourcePosLine $ spanStart ss diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 01552f4434..121519487f 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -102,7 +102,7 @@ properNameToJSON :: ProperName a -> Value properNameToJSON = toJSON . runProperName qualifiedToJSON :: (a -> Text) -> Qualified a -> Value -qualifiedToJSON f (Qualified qb a) = +qualifiedToJSON f (Qualified qb a _) = case qb of ByModuleName mn -> object [ "moduleName" .= moduleNameToJSON mn diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index f4f4c8fdcb..a8d7487812 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -83,7 +83,7 @@ insertValueTypesAndAdjustKinds env m = where inferredRoles :: [P.Role] inferredRoles = do - let key = P.Qualified (P.ByModuleName (modName m)) (P.properNameFromString (declTitle d)) + let key = P.mkQualified_ (P.ByModuleName (modName m)) (P.properNameFromString (declTitle d)) case Map.lookup key (P.types env) of Just (_, tyKind) -> case tyKind of P.DataType _ tySourceTyRole _ -> @@ -162,7 +162,7 @@ insertValueTypesAndAdjustKinds env m = either (err . ("failed to parse Ident: " ++)) identity . runParser CST.parseIdent lookupName name = - let key = P.Qualified (P.ByModuleName (modName m)) name + let key = P.mkQualified_ (P.ByModuleName (modName m)) name in case Map.lookup key (P.names env) of Just (ty, _, _) -> ty @@ -213,7 +213,7 @@ insertValueTypesAndAdjustKinds env m = insertInferredKind :: Declaration -> Text -> P.KindSignatureFor -> Declaration insertInferredKind d name keyword = let - key = P.Qualified (P.ByModuleName (modName m)) (P.properNameFromString name) + key = P.mkQualified_ (P.ByModuleName (modName m)) (P.properNameFromString name) in case Map.lookup key (P.types env) of Just (inferredKind, _) -> if isUninteresting keyword inferredKind' diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index 5376a6a8a6..840c64c866 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -511,7 +511,7 @@ typeClassConstraintFor :: Declaration -> Maybe Constraint' typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ _ -> - Just (P.Constraint () (P.Qualified P.ByNullSourcePos (P.properNameFromString declTitle)) [] (mkConstraint tyArgs) Nothing) + Just (P.Constraint () (P.mkQualified_ P.ByNullSourcePos (P.properNameFromString declTitle)) [] (mkConstraint tyArgs) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index b3b15e7b4f..36f25a9421 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -192,17 +192,17 @@ convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ _ constraints clas where classNameString = unQual className typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) - unQual x = let (P.Qualified _ y) = x in P.runProperName y + unQual x = let (P.Qualified _ y _) = x in P.runProperName y extractProperNames (P.TypeConstructor _ n) = [unQual n] extractProperNames _ = [] childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance (fmap ($> ()) constraints) (classApp $> ())) classApp = foldl' P.srcTypeApp (P.srcTypeConstructor (fmap P.coerceProperName className)) tys -convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title = - Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias))) -convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title = - Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Left alias))) +convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias _) _) title = + Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.mkQualified_ mn (Right alias))) +convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias _) _) title = + Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.mkQualified_ mn (Left alias))) convertDeclaration (P.KindDeclaration sa keyword _ kind) title = Just $ Left ([(title, AugmentType), (title, AugmentClass)], AugmentKindSig ksi) where diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 5d486e43c8..19bead59f1 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -123,10 +123,10 @@ renderConstraints constraints (map renderConstraint constraints) notQualified :: Text -> P.Qualified (P.ProperName a) -notQualified = P.Qualified P.ByNullSourcePos . P.properNameFromString +notQualified = P.mkQualified_ P.ByNullSourcePos . P.properNameFromString ident' :: Text -> RenderedCode -ident' = ident . P.Qualified P.ByNullSourcePos . P.Ident +ident' = ident . P.mkQualified_ P.ByNullSourcePos . P.Ident dataCtor' :: Text -> RenderedCode dataCtor' = dataCtor . notQualified diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index ab5753a801..fef389ee92 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -45,7 +45,7 @@ import Data.Text qualified as T import Data.ByteString.Lazy qualified as BS import Data.Text.Encoding qualified as TE -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName, runProperName, properNameFromString) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName, runProperName, properNameFromString, mkQualified_) import Language.PureScript.AST (Associativity(..)) -- | Given a list of actions, attempt them all, returning the first success. @@ -117,8 +117,8 @@ maybeToContainingModule Nothing = ThisModule maybeToContainingModule (Just mn) = OtherModule mn fromQualified :: Qualified a -> (ContainingModule, a) -fromQualified (Qualified (ByModuleName mn) x) = (OtherModule mn, x) -fromQualified (Qualified _ x) = (ThisModule, x) +fromQualified (Qualified (ByModuleName mn) x _) = (OtherModule mn, x) +fromQualified (Qualified _ x _) = (ThisModule, x) data Link = NoLink @@ -296,9 +296,9 @@ aliasName for name' = in case ns of ValueLevel -> - ident (Qualified ByNullSourcePos (Ident name)) + ident (mkQualified_ ByNullSourcePos (Ident name)) TypeLevel -> - typeCtor (Qualified ByNullSourcePos (properNameFromString name)) + typeCtor (mkQualified_ ByNullSourcePos (properNameFromString name)) -- | Converts a FixityAlias into a different representation which is more -- useful to other functions in this module. diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index c4e6cbecaa..3ff86b7bca 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -273,13 +273,13 @@ isType Declaration{..} = isValueAlias :: Declaration -> Bool isValueAlias Declaration{..} = case declInfo of - AliasDeclaration _ (P.Qualified _ d) -> isRight d + AliasDeclaration _ (P.Qualified _ d _) -> isRight d _ -> False isTypeAlias :: Declaration -> Bool isTypeAlias Declaration{..} = case declInfo of - AliasDeclaration _ (P.Qualified _ d) -> isLeft d + AliasDeclaration _ (P.Qualified _ d _) -> isLeft d _ -> False -- | Discard any children which do not satisfy the given predicate. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 309a4e9ba9..e444a5fa85 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -766,35 +766,35 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" - renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.S_bind, C.S_discard ] = + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)) _)) | i `elem` [ C.S_bind, C.S_discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " and " <> markCode "discard" <> " functions. Please import " <> markCode i <> " from module " <> markCode "Prelude" - renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident C.S_negate)))) = + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident C.S_negate)) _)) = line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode C.S_negate <> " function. Please import " <> markCode C.S_negate <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = - paras [ line $ "Cannot import " <> printName (Qualified ByNullSourcePos name) <> " from module " <> markCode (runModuleName mn) + paras [ line $ "Cannot import " <> printName (Qualified ByNullSourcePos name 0) <> " from module " <> markCode (runModuleName mn) , line "It either does not exist or the module does not export it." ] renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = line $ "Module " <> runModuleName mn <> " does not export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) renderSimpleErrorMessage (UnknownExport name) = - line $ "Cannot export unknown " <> printName (Qualified ByNullSourcePos name) + line $ "Cannot export unknown " <> printName (Qualified ByNullSourcePos name 0 ) renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = line $ "Cannot export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) <> ", as it has not been declared." renderSimpleErrorMessage (ScopeConflict nm ms) = - paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified ByNullSourcePos nm) <> " from the following modules:" + paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified ByNullSourcePos nm 0) <> " from the following modules:" , indent $ paras $ map (line . markCode . runModuleName) ms ] renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = - paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified ByNullSourcePos nm) <> " from the following open imports:" + paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified ByNullSourcePos nm 0) <> " from the following open imports:" , indent $ paras $ map (line . markCode . ("import " <>) . runModuleName) ms , line $ "These will be ignored and the " <> case exmn of Just exmn' -> "declaration from " <> markCode (runModuleName exmn') <> " will be used." Nothing -> "local declaration will be used." ] renderSimpleErrorMessage (DeclConflict new existing) = - line $ "Declaration for " <> printName (Qualified ByNullSourcePos new) <> " conflicts with an existing " <> nameType existing <> " of the same name." + line $ "Declaration for " <> printName (Qualified ByNullSourcePos new 0) <> " conflicts with an existing " <> nameType existing <> " of the same name." renderSimpleErrorMessage (ExportConflict new existing) = line $ "Export for " <> printName new <> " conflicts with " <> printName existing renderSimpleErrorMessage (DuplicateModule mn) = @@ -1200,7 +1200,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon renderSimpleErrorMessage msg@(UnusedExplicitImport mn names _ _) = paras [ line $ "The import of module " <> markCode (runModuleName mn) <> " contains the following unused references:" - , indent $ paras $ map (line . markCode . runName . Qualified ByNullSourcePos) names + , indent $ paras $ map (line . markCode . runName . mkQualified_ ByNullSourcePos ) names , line "It could be replaced with:" , indent $ line $ markCode $ showSuggestion msg ] @@ -1224,10 +1224,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon line $ "Duplicate import of " <> markCode (prettyPrintImport name imp qual) renderSimpleErrorMessage (DuplicateImportRef name) = - line $ "Import list contains multiple references to " <> printName (Qualified ByNullSourcePos name) + line $ "Import list contains multiple references to " <> printName (Qualified ByNullSourcePos name 0) renderSimpleErrorMessage (DuplicateExportRef name) = - line $ "Export list contains multiple references to " <> printName (Qualified ByNullSourcePos name) + line $ "Export list contains multiple references to " <> printName (Qualified ByNullSourcePos name 0) renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = paras [ line $ "Integer value " <> markCode (T.pack (show value)) <> " is out of range for the " <> backend <> " backend." @@ -1673,21 +1673,21 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon nameType (ModName _) = "module" runName :: Qualified Name -> Text - runName (Qualified qb (IdentName name)) = - showQualified showIdent (Qualified qb name) - runName (Qualified qb (ValOpName op)) = - showQualified showOp (Qualified qb op) - runName (Qualified qb (TyName name)) = - showQualified runProperName (Qualified qb name) - runName (Qualified qb (TyOpName op)) = - showQualified showOp (Qualified qb op) - runName (Qualified qb (DctorName name)) = - showQualified runProperName (Qualified qb name) - runName (Qualified qb (TyClassName name)) = - showQualified runProperName (Qualified qb name) - runName (Qualified (BySourcePos _) (ModName name)) = + runName (Qualified qb (IdentName name) _) = + showQualified showIdent (Qualified qb name 0) + runName (Qualified qb (ValOpName op) _) = + showQualified showOp (Qualified qb op 0) + runName (Qualified qb (TyName name) _) = + showQualified runProperName (Qualified qb name 0) + runName (Qualified qb (TyOpName op) _) = + showQualified showOp (Qualified qb op 0) + runName (Qualified qb (DctorName name) _) = + showQualified runProperName (Qualified qb name 0) + runName (Qualified qb (TyClassName name) _) = + showQualified runProperName (Qualified qb name 0) + runName (Qualified (BySourcePos _) (ModName name) _) = runModuleName name - runName (Qualified _ ModName{}) = + runName (Qualified _ ModName{} _) = internalError "qualified ModName in runName" prettyDepth :: Int @@ -1790,7 +1790,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon prettyInstanceName :: Qualified (Either SourceType Ident) -> Box.Box prettyInstanceName = \case - Qualified qb (Left ty) -> + Qualified qb (Left ty) _ -> "instance " Box.<> (case qb of ByModuleName mn -> "in module " @@ -1801,7 +1801,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon Box.<> markCodeBox (prettyType ty) Box.<> " " Box.<> (line . displayStartEndPos . fst $ getAnnForType ty) - Qualified mn (Right inst) -> line . markCode . showQualified showIdent $ Qualified mn inst + Qualified mn (Right inst) _ -> line . markCode . showQualified showIdent $ mkQualified_ mn inst -- As of this writing, this function assumes that all provided SourceSpans -- are non-overlapping (except for exact duplicates) and span no line breaks. A diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a949aacae6..abf42d686c 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -35,7 +35,7 @@ import Language.PureScript.AST (Associativity, Declaration(..), DeclarationRef(. import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType, Environment(..), FunctionalDependency, NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), dictTypeName, makeTypeClassData) -import Language.PureScript.Names (Ident, ModuleName, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, isPlainIdent) +import Language.PureScript.Names (Ident, ModuleName, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, isPlainIdent, mkQualified_) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) import Language.PureScript.Types (SourceConstraint, SourceType, srcInstanceType) @@ -179,7 +179,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) } applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } - applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (ByModuleName efModuleName) ident) (ty, External, Defined) (names env) } + applyDecl env (EDValue ident ty) = env { names = M.insert (mkQualified_ (ByModuleName efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) = env { typeClassDictionaries = @@ -199,7 +199,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar UserNamed -> Nothing qual :: a -> Qualified a - qual = Qualified (ByModuleName efModuleName) + qual = mkQualified_ (ByModuleName efModuleName) -- | Generate an externs file for all declarations in a module. -- @@ -237,26 +237,26 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] toExternsDeclaration (TypeRef _ pn dctors) = - case Qualified (ByModuleName mn) pn `M.lookup` types env of + case mkQualified_ (ByModuleName mn) pn `M.lookup` types env of Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration" Just (kind, TypeSynonym) - | Just (args, synTy) <- Qualified (ByModuleName mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] + | Just (args, synTy) <- mkQualified_ (ByModuleName mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] Just (kind, ExternData rs) -> [ EDType pn kind (ExternData rs) ] Just (kind, tk@(DataType _ _ tys)) -> EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args | dctor <- fromMaybe (map fst tys) dctors - , (dty, _, ty, args) <- maybeToList (Qualified (ByModuleName mn) dctor `M.lookup` dataConstructors env) + , (dty, _, ty, args) <- maybeToList (mkQualified_ (ByModuleName mn) dctor `M.lookup` dataConstructors env) ] _ -> internalError "toExternsDeclaration: Invalid input" toExternsDeclaration (ValueRef _ ident) - | Just (ty, _, _) <- Qualified (ByModuleName mn) ident `M.lookup` names env + | Just (ty, _, _) <- mkQualified_ (ByModuleName mn) ident `M.lookup` names env = [ EDValue (lookupRenamedIdent ident) ty ] toExternsDeclaration (TypeClassRef _ className) | let dictName = dictTypeName . coerceProperName $ className - , Just TypeClassData{..} <- Qualified (ByModuleName mn) className `M.lookup` typeClasses env - , Just (kind, tk) <- Qualified (ByModuleName mn) (coerceProperName className) `M.lookup` types env - , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- Qualified (ByModuleName mn) dictName `M.lookup` types env - , Just (dty, _, ty, args) <- Qualified (ByModuleName mn) dctor `M.lookup` dataConstructors env + , Just TypeClassData{..} <- mkQualified_ (ByModuleName mn) className `M.lookup` typeClasses env + , Just (kind, tk) <- mkQualified_ (ByModuleName mn) (coerceProperName className) `M.lookup` types env + , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- mkQualified_ (ByModuleName mn) dictName `M.lookup` types env + , Just (dty, _, ty, args) <- mkQualified_ (ByModuleName mn) dctor `M.lookup` dataConstructors env = [ EDType (coerceProperName className) kind tk , EDType dictName dictKind dictData , EDDataConstructor dctor dty dictName ty args @@ -266,7 +266,7 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss' | m1 <- maybeToList (M.lookup (ByModuleName mn) (typeClassDictionaries env)) , m2 <- M.elems m1 - , nel <- maybeToList (M.lookup (Qualified (ByModuleName mn) ident) m2) + , nel <- maybeToList (M.lookup (mkQualified_ (ByModuleName mn) ident) m2) , TypeClassDictionaryInScope{..} <- NEL.toList nel ] toExternsDeclaration _ = [] diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index 09fb792bda..6e86a63e56 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -80,6 +80,6 @@ typeClassEpilogue = "\n}" superClasses :: P.Declaration -> [SuperMap] superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) = - fmap (\(P.Constraint _ (P.Qualified _ super) _ _ _) -> SuperMap (Right (super, sub))) supers + fmap (\(P.Constraint _ (P.Qualified _ super _) _ _ _) -> SuperMap (Right (super, sub))) supers superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)] superClasses _ = [] diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 8a23f574e0..437d947d45 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -63,7 +63,7 @@ encodeRebuildErrors files = toJSON . map encodeRebuildError . P.runMultipleError ]) value) insertTSCompletions _ _ _ v = v - identCompletion (P.Qualified mn i, ty) = + identCompletion (P.Qualified mn i _, ty) = Completion { complModule = maybe "" P.runModuleName $ P.toMaybeModuleName mn , complIdentifier = i diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 14818e1392..e091513744 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -360,7 +360,7 @@ resolveInstances externs declarations = where extractInstances mn P.EDInstance{..} = case edInstanceClassName of - P.Qualified (P.ByModuleName classModule) className -> + P.Qualified (P.ByModuleName classModule) className _ -> Just (IdeInstance mn edInstanceName edInstanceTypes @@ -404,14 +404,14 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) & foldMap (map discardAnn) resolveOperator (IdeDeclValueOperator op) - | (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias = + | (P.Qualified (P.ByModuleName mn) (Left ident) _) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclValue) & filter (anyOf ideValueIdent (== ident)) & map (view ideValueType) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) - | (P.Qualified (P.ByModuleName mn) (Right dtor)) <- op ^. ideValueOpAlias = + | (P.Qualified (P.ByModuleName mn) (Right dtor) _) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclDataConstructor) & filter (anyOf ideDtorName (== dtor)) @@ -419,7 +419,7 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) resolveOperator (IdeDeclTypeOperator op) - | P.Qualified (P.ByModuleName mn) properName <- op ^. ideTypeOpAlias = + | P.Qualified (P.ByModuleName mn) properName _ <- op ^. ideTypeOpAlias = let k = getDeclarations mn & mapMaybe (preview _IdeDeclType) & filter (anyOf ideTypeName (== properName)) diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 3e773efe5a..68711e50b9 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -67,7 +67,7 @@ directDependants declaration modules mn = Map.mapMaybe (nonEmpty . go) modules go = foldMap isImporting . P.getModuleDeclarations isImporting d = case d of - P.ImportDeclaration _ mn' it qual | mn == mn' -> P.Qualified (P.byMaybeModuleName qual) <$> case it of + P.ImportDeclaration _ mn' it qual | mn == mn' -> P.mkQualified_ (P.byMaybeModuleName qual) <$> case it of P.Implicit -> pure declaration P.Explicit refs | any (declaration `matchesRef`) refs -> pure declaration @@ -120,7 +120,7 @@ eligibleModules -> ModuleMap (NonEmpty Search) eligibleModules query@(moduleName, declaration) decls modules = let - searchDefiningModule = P.Qualified P.ByNullSourcePos declaration :| [] + searchDefiningModule = P.mkQualified_ P.ByNullSourcePos declaration :| [] in Map.insert moduleName searchDefiningModule $ foldMap (directDependants declaration modules) (moduleName :| findReexportingModules query decls) diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 3c0ae0ed21..8070a6a757 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -293,7 +293,7 @@ handleKindOf print' typ = do case e of Left errs -> printErrors errs Right (_, env') -> - case M.lookup (P.Qualified (P.ByModuleName mName) $ P.ProperName "IT") (P.typeSynonyms env') of + case M.lookup (P.mkQualified_ (P.ByModuleName mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } k = undefined -- TODO: check (snd <$> P.kindOf typ') chk diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs index 61083eee2e..5419aac39a 100644 --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -40,14 +40,14 @@ createTemporaryModule exec st val = effModuleName = P.ModuleName "Effect" effImport = (effModuleName, P.Implicit, Just (P.ModuleName "$Effect")) supportImport = (fst (psciInteractivePrint st), P.Implicit, Just (P.ModuleName "$Support")) - eval = P.Var internalSpan (P.Qualified (P.ByModuleName (P.ModuleName "$Support")) (snd (psciInteractivePrint st))) - mainValue = P.App eval (P.Var internalSpan (P.Qualified P.ByNullSourcePos (P.Ident "it"))) + eval = P.Var internalSpan (P.mkQualified_ (P.ByModuleName (P.ModuleName "$Support")) (snd (psciInteractivePrint st))) + mainValue = P.App eval (P.Var internalSpan (P.mkQualified_ P.ByNullSourcePos (P.Ident "it"))) itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] typeDecl = P.TypeDeclaration (P.TypeDeclarationData (internalSpan, []) (P.Ident "$main") (P.srcTypeApp (P.srcTypeConstructor - (P.Qualified (P.ByModuleName (P.ModuleName "$Effect")) (P.ProperName "Effect"))) + (P.mkQualified_ (P.ByModuleName (P.ModuleName "$Effect")) (P.ProperName "Effect"))) P.srcTypeWildcard)) mainDecl = P.ValueDecl (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index ed2d145219..a56231a18f 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -58,12 +58,12 @@ printModuleSignatures moduleName P.Environment{..} = :: (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData) -> Maybe Box.Box showTypeClass (_, Nothing) = Nothing - showTypeClass (P.Qualified _ name, Just P.TypeClassData{..}) = + showTypeClass (P.Qualified _ name _, Just P.TypeClassData{..}) = let constraints = if null typeClassSuperclasses then Box.text "" else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) _ lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map (P.typeAtomAsBox maxBound) lt)) typeClassSuperclasses) + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn _) _ lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map (P.typeAtomAsBox maxBound) lt)) typeClassSuperclasses) Box.<> Box.text ") <= " className = textT (P.runProperName name) @@ -92,7 +92,7 @@ printModuleSignatures moduleName P.Environment{..} = -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.SourceType)], P.SourceType) -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceType, P.TypeKind)) -> Maybe Box.Box - showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = + showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name _), typ) = case (typ, M.lookup n typeSynonymsEnv) of (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> if M.member (fmap P.coerceProperName n) typeClassesEnv @@ -107,7 +107,7 @@ printModuleSignatures moduleName P.Environment{..} = let prefix = case pt of [(dtProperName,_)] -> - case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of + case M.lookup (P.mkQualified_ modul dtProperName) dataConstructorsEnv of Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType _ -> "data" _ -> "data" diff --git a/src/Language/PureScript/Interner.hs b/src/Language/PureScript/Interner.hs index 00d9823449..2f93f9a1b4 100644 --- a/src/Language/PureScript/Interner.hs +++ b/src/Language/PureScript/Interner.hs @@ -9,6 +9,7 @@ module Language.PureScript.Interner , textInterner , internPSString , uninternPSString + , getInternedHash ) where import Prelude @@ -28,6 +29,11 @@ import System.Random (randomIO) newtype Interned = Interned Int deriving (Eq, Ord, NFData) +instance Hashable Interned where + hashWithSalt salt (Interned i) = hashWithSalt salt i + +getInternedHash :: Interned -> Int +getInternedHash (Interned i) = i instance IsString Interned where fromString s = internText (fromString s) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index 9bce1909de..ff6e3f9be8 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -183,13 +183,13 @@ lintUnused (Module modSS _ mn modDecls exports) = in (vars, errs') - goDecl (ValueFixityDeclaration _ _ (Qualified _ (Left v)) _) = (S.singleton v, mempty) + goDecl (ValueFixityDeclaration _ _ (Qualified _ (Left v) _) _) = (S.singleton v, mempty) goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls goDecl _ = mempty go :: Expr -> (S.Set Ident, MultipleErrors) - go (Var _ (Qualified (BySourcePos _) v)) = (S.singleton v, mempty) + go (Var _ (Qualified (BySourcePos _) v _)) = (S.singleton v, mempty) go (Var _ _) = (S.empty, mempty) go (Let _ ds e) = onDecls ds (go e) diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 697fefe8a0..28e7623449 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -49,7 +49,7 @@ qualifyName -> ModuleName -> Qualified (ProperName b) -> Qualified (ProperName a) -qualifyName n defmn qn = Qualified (ByModuleName mn) n +qualifyName n defmn qn = mkQualified_ (ByModuleName mn) n where (mn, _) = qualify defmn qn diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index e8a2eb0f2c..70d049ac6c 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -189,14 +189,14 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do -> [(ModuleName, Qualified Name)] extractByQual k m toName = mapMaybe go (M.toList m) where - go (q@(Qualified mnq _), is) + go (q@(Qualified mnq _ _), is) | isUnqualified q = case find (isQualifiedWith k) (map importName is) of - Just (Qualified _ name) -> Just (k, Qualified mnq (toName name)) + Just (Qualified _ name _) -> Just (k, mkQualified_ mnq (toName name)) _ -> Nothing | isQualifiedWith k q = case importName (head is) of - Qualified (ByModuleName mn') name -> Just (mn', Qualified mnq (toName name)) + Qualified (ByModuleName mn') name _ -> Just (mn', mkQualified_ mnq (toName name)) _ -> internalError "unqualified name in extractByQual" go _ = Nothing diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 5877b2c722..899e31f864 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -372,12 +372,12 @@ splitRefs new old toRef = typeDeps :: P.Type a -> S.Set (ModuleName, Ref) typeDeps = P.everythingOnTypes (<>) $ \case - P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn) + P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn _) | isPrimModule mn -> mempty | otherwise -> S.singleton (mn, TypeRef tn) P.TypeConstructor _ _ -> internalError "typeDeps: type is not qualified" - P.TypeOp _ (P.Qualified (P.ByModuleName mn) tn) + P.TypeOp _ (P.Qualified (P.ByModuleName mn) tn _) | isPrimModule mn -> mempty | otherwise -> S.singleton (mn, TypeOpRef tn) P.ConstrainedType _ c _ -> @@ -387,7 +387,7 @@ typeDeps = P.everythingOnTypes (<>) $ _ -> mempty qualified :: P.Qualified b -> (ModuleName, b) -qualified (P.Qualified (P.ByModuleName mn) v) = (mn, v) +qualified (P.Qualified (P.ByModuleName mn) v _) = (mn, v) qualified _ = internalError "ExternsDiff: type is not qualified" -- | To get fixity's data constructor dependency we should provide it with the @@ -451,7 +451,7 @@ externsDeclarationToRef moduleName = \case typeKindDeps (P.DataType _ args _) = foldMap goDataTypeArg args typeKindDeps _ = mempty - myType (P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn)) + myType (P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn _)) | isPrimModule mn || moduleName /= mn = Nothing | otherwise = Just tn myType _ = Nothing diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 2738f8d120..7a69443fff 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} -- | -- Data types for names @@ -22,7 +23,8 @@ import Data.Text qualified as T import Data.Int (Int64) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) -import Language.PureScript.Interner (Interned, uninternText, internText) +import Language.PureScript.Interner (Interned, uninternText, internText, getInternedHash) +import Data.Hashable (Hashable (..)) -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -72,7 +74,7 @@ getClassName _ = Nothing data InternalIdentData -- Used by CoreFn.Laziness = RuntimeLazyFactory | Lazy !Text - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Hashable) instance NFData InternalIdentData instance Serialise InternalIdentData @@ -97,7 +99,7 @@ data Ident -- A generated name used only for internTextal transformations -- | InternalIdent !InternalIdentData - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Hashable) instance NFData Ident instance Serialise Ident @@ -130,6 +132,7 @@ isPlainIdent _ = False -- newtype OpName (a :: OpNameType) = OpName { runOpName :: Text } deriving (Show, Eq, Ord, Generic) + deriving newtype Hashable instance NFData (OpName a) instance Serialise (OpName a) @@ -159,7 +162,7 @@ coerceOpName = OpName . runOpName -- newtype ProperName (a :: ProperNameType) = ProperName { unProperName :: Interned } deriving (Eq, Ord, Generic) - deriving newtype (NFData) + deriving newtype (NFData, Hashable) properNameFromString :: Text -> ProperName a properNameFromString = ProperName . internText @@ -202,6 +205,8 @@ coerceProperName = ProperName . unProperName -- newtype ModuleName = ModuleName Interned deriving (Show, Eq, Ord, Generic) + deriving newtype (Hashable) + instance Serialise ModuleName where encode (ModuleName i) = encode (uninternText i) @@ -221,11 +226,13 @@ isBuiltinModuleName mn' = let mn = runModuleName mn' in mn == "Prim" || "Prim." data QualifiedBy = BySourcePos SourcePos | ByModuleName ModuleName - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Hashable) + pattern ByNullSourcePos :: QualifiedBy pattern ByNullSourcePos = BySourcePos (SourcePos 0 0) + instance NFData QualifiedBy instance Serialise QualifiedBy @@ -244,49 +251,66 @@ toMaybeModuleName (BySourcePos _) = Nothing -- | -- A qualified name, i.e. a name with an optional module name -- -data Qualified a = Qualified QualifiedBy a - deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) +data Qualified a = Qualified QualifiedBy a Int + deriving (Functor, Foldable, Traversable, Generic) + +instance Show a => Show (Qualified a) where + show (Qualified qb a _) = case qb of + BySourcePos _ -> show a + ByModuleName mn -> T.unpack (runModuleName mn) <> "." <> show a instance NFData a => NFData (Qualified a) instance Serialise a => Serialise (Qualified a) +instance Eq a => Eq (Qualified a) where + (Qualified qb a _) == (Qualified qb' a' _) = qb == qb' && a == a' + +instance Ord a => Ord (Qualified a) where + compare (Qualified qb a1 _) (Qualified qb' a2 _) = case compare qb qb' of + EQ -> compare a1 a2 + other -> other + showQualified :: (a -> Text) -> Qualified a -> Text -showQualified f (Qualified (BySourcePos _) a) = f a -showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a +showQualified f (Qualified (BySourcePos _) a _) = f a +showQualified f (Qualified (ByModuleName name) a _) = runModuleName name <> "." <> f a getQual :: Qualified a -> Maybe ModuleName -getQual (Qualified qb _) = toMaybeModuleName qb +getQual (Qualified qb _ _) = toMaybeModuleName qb -- | -- Provide a default module name, if a name is unqualified -- qualify :: ModuleName -> Qualified a -> (ModuleName, a) -qualify m (Qualified (BySourcePos _) a) = (m, a) -qualify _ (Qualified (ByModuleName m) a) = (m, a) +qualify m (Qualified (BySourcePos _) a _) = (m, a) +qualify _ (Qualified (ByModuleName m) a _) = (m, a) -- | -- Makes a qualified value from a name and module name. -- mkQualified :: a -> ModuleName -> Qualified a -mkQualified name mn = Qualified (ByModuleName mn) name +mkQualified name mn@(ModuleName i) = Qualified (ByModuleName mn) name (getInternedHash i) + +mkQualified_ :: QualifiedBy -> a -> Qualified a +mkQualified_ qb name = Qualified qb name (hash qb) + -- | Remove the module name from a qualified name disqualify :: Qualified a -> a -disqualify (Qualified _ a) = a +disqualify (Qualified _ a _) = a -- | -- Remove the qualification from a value when it is qualified with a particular -- module name. -- disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a -disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a +disqualifyFor mn (Qualified qb a _) | mn == toMaybeModuleName qb = Just a disqualifyFor _ _ = Nothing -- | -- Checks whether a qualified value is actually qualified with a module reference -- isQualified :: Qualified a -> Bool -isQualified (Qualified (BySourcePos _) _) = False +isQualified (Qualified (BySourcePos _) _ _) = False isQualified _ = True -- | @@ -299,26 +323,26 @@ isUnqualified = not . isQualified -- Checks whether a qualified value is qualified with a particular module -- isQualifiedWith :: ModuleName -> Qualified a -> Bool -isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn' +isQualifiedWith mn (Qualified (ByModuleName mn') _ _) = mn == mn' isQualifiedWith _ _ = False instance ToJSON a => ToJSON (Qualified a) where - toJSON (Qualified qb a) = case qb of + toJSON (Qualified qb a _) = case qb of ByModuleName mn -> toJSON2 (mn, a) BySourcePos ss -> toJSON2 (ss, a) -instance FromJSON a => FromJSON (Qualified a) where +instance (FromJSON a, Hashable a) => FromJSON (Qualified a) where parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName' where byModule = do (mn, a) <- parseJSON2 v - pure $ Qualified (ByModuleName mn) a + pure $ mkQualified_ (ByModuleName mn) a bySourcePos = do (ss, a) <- parseJSON2 v - pure $ Qualified (BySourcePos ss) a + pure $ mkQualified_ (BySourcePos ss) a byMaybeModuleName' = do (mn, a) <- parseJSON2 v - pure $ Qualified (byMaybeModuleName mn) a + pure $ mkQualified_ (byMaybeModuleName mn) a instance ToJSON ModuleName where toJSON mn = toJSON (T.splitOn "." $ runModuleName mn) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index c4d4b955c3..7e614ee265 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -110,7 +110,7 @@ prettyPrintValueAtom _ (Var _ ident) = text $ T.unpack $ showIdent (disqualify i prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where - printOp (Op _ (Qualified _ name)) = text $ T.unpack $ runOpName name + printOp (Op _ (Qualified _ name _)) = text $ T.unpack $ runOpName name printOp expr = text "`" <> prettyPrintValue (d - 1) expr `before` text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index aff42ca288..f1a6f8317d 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -16,7 +16,7 @@ import Data.Set qualified as S import Data.Text qualified as T import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), Expr(..), Literal(..), Module(..)) -import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent, showIdent) +import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent, showIdent, mkQualified_) import Language.PureScript.Traversals (eitherM, pairM, sndM) -- | @@ -173,12 +173,12 @@ renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v renameInValue (App ann v1 v2) = App ann <$> renameInValue v1 <*> renameInValue v2 -renameInValue (Var ann (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) = +renameInValue (Var ann (Qualified qb name _)) | isBySourcePos qb || not (isPlainIdent name) = -- This should only rename identifiers local to the current module: either -- they aren't qualified, or they are but they have a name that should not -- have appeared in a module's externs, so they must be from this module's -- top-level scope. - Var ann . Qualified qb <$> lookupIdent name + Var ann . mkQualified_ qb <$> lookupIdent name renameInValue v@Var{} = return v renameInValue (Case ann vs alts) = newScope $ Case ann <$> traverse renameInValue vs <*> traverse renameInCaseAlternative alts diff --git a/src/Language/PureScript/Sugar/Accessor.hs b/src/Language/PureScript/Sugar/Accessor.hs index 02c3d6c991..4e765f275c 100644 --- a/src/Language/PureScript/Sugar/Accessor.hs +++ b/src/Language/PureScript/Sugar/Accessor.hs @@ -21,8 +21,8 @@ desugarAccessorModule externs m desugarAccessorModule _externs (Module ss coms mn ds exts) = let (ds', Any used) = runWriter $ traverse desugarAccessor ds extraImports = if used - then addDefaultImport (Qualified (ByModuleName C.M_Data_Record) C.M_Data_Record) - . addDefaultImport (Qualified (ByModuleName C.M_Type_Proxy) C.M_Type_Proxy) + then addDefaultImport (mkQualified_ (ByModuleName C.M_Data_Record) C.M_Data_Record) + . addDefaultImport (mkQualified_ (ByModuleName C.M_Type_Proxy) C.M_Type_Proxy) else id in extraImports $ Module ss coms mn ds' exts diff --git a/src/Language/PureScript/Sugar/AdoNotation.hs b/src/Language/PureScript/Sugar/AdoNotation.hs index 3ac5373621..65b4f9a5f0 100644 --- a/src/Language/PureScript/Sugar/AdoNotation.hs +++ b/src/Language/PureScript/Sugar/AdoNotation.hs @@ -11,7 +11,7 @@ import Control.Monad.Supply.Class (MonadSupply) import Data.List (foldl') import Language.PureScript.AST (Binder(..), CaseAlternative(..), Declaration, DoNotationElement(..), Expr(..), pattern MkUnguarded, Module(..), SourceSpan, WhereProvenance(..), declSourceSpan, everywhereOnValuesM) import Language.PureScript.Errors (MultipleErrors, parU, rethrowWithPosition) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), byMaybeModuleName, freshIdent') +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, byMaybeModuleName, freshIdent', mkQualified_) import Language.PureScript.Constants.Libs qualified as C -- | Replace all @AdoNotationBind@ and @AdoNotationValue@ constructors with @@ -28,13 +28,13 @@ desugarAdo d = in rethrowWithPosition ss $ f d where pure' :: SourceSpan -> Maybe ModuleName -> Expr - pure' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_pure)) + pure' ss m = Var ss (mkQualified_ (byMaybeModuleName m) (Ident C.S_pure)) map' :: SourceSpan -> Maybe ModuleName -> Expr - map' ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_map)) + map' ss m = Var ss (mkQualified_ (byMaybeModuleName m) (Ident C.S_map)) apply :: SourceSpan -> Maybe ModuleName -> Expr - apply ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_apply)) + apply ss m = Var ss (mkQualified_ (byMaybeModuleName m) (Ident C.S_apply)) replace :: SourceSpan -> Expr -> m Expr replace pos (Ado m els yield) = do @@ -53,7 +53,7 @@ desugarAdo d = go ss (yield, args) (DoNotationBind binder val) = do ident <- freshIdent' let abs = Abs (VarBinder ss ident) - (Case [Var ss (Qualified ByNullSourcePos ident)] + (Case [Var ss (mkQualified_ ByNullSourcePos ident)] [CaseAlternative [binder] [MkUnguarded yield]]) return (abs, val : args) go _ (yield, args) (DoNotationLet ds) = do diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index d2f9aebf2b..6e22727aec 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -28,7 +28,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (NameKind) import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..), errorMessage', parU, positionedError) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified_) import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), everythingOnTypes) data VertexType @@ -172,9 +172,9 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def usedNamesE :: S.Set ScopedIdent -> Expr -> [Ident] - usedNamesE scope (Var _ (Qualified (BySourcePos _) name)) + usedNamesE scope (Var _ (Qualified (BySourcePos _) name _)) | LocalIdent name `S.notMember` scope = [name] - usedNamesE scope (Var _ (Qualified (ByModuleName moduleName') name)) + usedNamesE scope (Var _ (Qualified (ByModuleName moduleName') name _)) | moduleName == moduleName' && ToplevelIdent name `S.notMember` scope = [name] usedNamesE _ _ = [] @@ -186,8 +186,8 @@ usedImmediateIdents moduleName = def s _ = (s, []) usedNamesE :: Bool -> Expr -> (Bool, [Ident]) - usedNamesE True (Var _ (Qualified (BySourcePos _) name)) = (True, [name]) - usedNamesE True (Var _ (Qualified (ByModuleName moduleName') name)) + usedNamesE True (Var _ (Qualified (BySourcePos _) name _)) = (True, [name]) + usedNamesE True (Var _ (Qualified (ByModuleName moduleName') name _)) | moduleName == moduleName' = (True, [name]) usedNamesE True (Abs _ _) = (False, []) usedNamesE scope _ = (scope, []) @@ -202,12 +202,12 @@ usedTypeNames moduleName = go usedNames :: SourceType -> [ProperName 'TypeName] usedNames (ConstrainedType _ con _) = usedConstraint con - usedNames (TypeConstructor _ (Qualified (ByModuleName moduleName') name)) + usedNames (TypeConstructor _ (Qualified (ByModuleName moduleName') name _)) | moduleName == moduleName' = [name] usedNames _ = [] usedConstraint :: SourceConstraint -> [ProperName 'TypeName] - usedConstraint (Constraint _ (Qualified (ByModuleName moduleName') name) _ _ _) + usedConstraint (Constraint _ (Qualified (ByModuleName moduleName') name _) _ _ _) | moduleName == moduleName' = [coerceProperName name] usedConstraint _ = [] @@ -275,8 +275,8 @@ toDataBindingGroup (CyclicSCC ds') $ typeSynonymCycles | otherwise = return . DataBindingGroupDeclaration . NEL.fromList $ getDecl <$> ds' where - kindDecl (KindDeclaration sa _ pn _) = [(fst sa, Qualified ByNullSourcePos pn)] - kindDecl (ExternDataDeclaration sa pn _) = [(fst sa, Qualified ByNullSourcePos pn)] + kindDecl (KindDeclaration sa _ pn _) = [(fst sa, mkQualified_ ByNullSourcePos pn)] + kindDecl (ExternDataDeclaration sa pn _) = [(fst sa, mkQualified_ ByNullSourcePos pn)] kindDecl _ = [] getDecl (decl, _, _) = decl diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index bcae767715..be64364a09 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -22,7 +22,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (NameKind(..)) import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..), addHint, errorMessage', parU, rethrow, withPosition) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, Qualified(..), freshIdent') +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, freshIdent', mkQualified_) import Language.PureScript.TypeChecker.Monad (guardWith) -- | @@ -64,7 +64,7 @@ desugarGuardedExprs ss (Case scrut alternatives) -- We bind the scrutinee to Vars here to mitigate this case. (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' - pure ( Var ss (Qualified ByNullSourcePos scrut_id) + pure ( Var ss (mkQualified_ ByNullSourcePos scrut_id) , ValueDecl (ss, []) scrut_id Private [] [MkUnguarded e] ) ) @@ -226,7 +226,7 @@ desugarGuardedExprs ss (Case scrut alternatives) = let goto_rem_case :: Expr - goto_rem_case = Var ss (Qualified ByNullSourcePos rem_case_id) + goto_rem_case = Var ss (mkQualified_ ByNullSourcePos rem_case_id) `App` Literal ss (BooleanLiteral True) alt_fail :: Int -> [CaseAlternative] alt_fail n = [CaseAlternative (replicate n NullBinder) [MkUnguarded goto_rem_case]] @@ -313,7 +313,7 @@ desugarAbs = flip parU f pure (Abs (VarBinder ss i) val) replace (Abs binder val) = do ident <- freshIdent' - return $ Abs (VarBinder nullSourceSpan ident) $ Case [Var nullSourceSpan (Qualified ByNullSourcePos ident)] [CaseAlternative [binder] [MkUnguarded val]] + return $ Abs (VarBinder nullSourceSpan ident) $ Case [Var nullSourceSpan (mkQualified_ ByNullSourcePos ident)] [CaseAlternative [binder] [MkUnguarded val]] replace other = return other stripPositioned :: Binder -> Binder @@ -381,7 +381,7 @@ makeCaseDeclaration ss ident alternatives = do args <- if allUnique (catMaybes argNames) then mapM argName argNames else replicateM (length argNames) ((nullSourceSpan, ) <$> freshIdent') - let vars = map (Var ss . Qualified ByNullSourcePos . snd) args + let vars = map (Var ss . mkQualified_ ByNullSourcePos . snd) args binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] let value = foldr (Abs . uncurry VarBinder) (Case vars binders) args diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 8542a5a790..3e570b37e1 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -13,7 +13,7 @@ import Data.Monoid (First(..)) import Language.PureScript.AST (Binder(..), CaseAlternative(..), Declaration, DoNotationElement(..), Expr(..), pattern MkUnguarded, Module(..), SourceSpan, pattern ValueDecl, WhereProvenance(..), binderNames, declSourceSpan, everywhereOnValuesM) import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', parU, rethrowWithPosition) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), byMaybeModuleName, freshIdent') +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, byMaybeModuleName, freshIdent', mkQualified_) import Language.PureScript.Constants.Libs qualified as C -- | Replace all @DoNotationBind@ and @DoNotationValue@ constructors with @@ -30,10 +30,10 @@ desugarDo d = in rethrowWithPosition ss $ f d where bind :: SourceSpan -> Maybe ModuleName -> Expr - bind ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_bind)) + bind ss m = Var ss (mkQualified_ (byMaybeModuleName m) (Ident C.S_bind)) discard :: SourceSpan -> Maybe ModuleName -> Expr - discard ss m = Var ss (Qualified (byMaybeModuleName m) (Ident C.S_discard)) + discard ss m = Var ss (mkQualified_ (byMaybeModuleName m) (Ident C.S_discard)) replace :: SourceSpan -> Expr -> m Expr replace pos (Do m els) = go pos m els @@ -70,7 +70,7 @@ desugarDo d = 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 ByNullSourcePos ident)] [CaseAlternative [binder] [MkUnguarded rest']])) + return $ App (App (bind pos m) val) (Abs (VarBinder pos ident) (Case [Var pos (mkQualified_ ByNullSourcePos 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 d081764d7f..3ab9914de1 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -28,7 +28,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage'', nonEmpty, parU, warnAndRethrow, warnAndRethrowWithPosition) import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..), ExternsImport(..)) import Language.PureScript.Linter.Imports (Name(..), UsedImports) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..)) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), mkQualified_) import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), checkImportConflicts, nullImports, primEnv) import Language.PureScript.Sugar.Names.Exports (findExportable, resolveExports) import Language.PureScript.Sugar.Names.Imports (resolveImports, resolveModuleImport) @@ -232,15 +232,15 @@ renameInModule imports (Module modSS coms mn decls exps) = TypeFixityDeclaration sa fixity <$> updateTypeName alias ss <*> pure op - updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Left alias)) op) = + updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Left alias) _) op) = fmap (bound,) $ ValueFixityDeclaration sa fixity . fmap Left - <$> updateValueName (Qualified mn' alias) ss + <$> updateValueName (mkQualified_ mn' alias) ss <*> pure op - updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Right alias)) op) = + updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Right alias) _) op) = fmap (bound,) $ ValueFixityDeclaration sa fixity . fmap Right - <$> updateDataConstructorName (Qualified mn' alias) ss + <$> updateDataConstructorName (mkQualified_ mn' alias) ss <*> pure op updateDecl b d = return (b, d) @@ -264,11 +264,11 @@ renameInModule imports (Module modSS coms mn decls exps) = when (nonEmpty duplicateArgsErrs) $ throwError duplicateArgsErrs return ((pos, declarationsToMap ds `M.union` bound), Let w ds val') - updateValue (_, bound) (Var ss name'@(Qualified qualifiedBy ident)) = + updateValue (_, bound) (Var ss name'@(Qualified qualifiedBy ident _)) = ((ss, bound), ) <$> case (M.lookup ident bound, qualifiedBy) of -- bound idents that have yet to be locally qualified. (Just sourcePos, ByNullSourcePos) -> - pure $ Var ss (Qualified (BySourcePos sourcePos) ident) + pure $ Var ss (mkQualified_ (BySourcePos sourcePos) ident) -- unbound idents are likely import unqualified imports, so we -- handle them through updateValueName if they don't exist as a -- local binding. @@ -412,7 +412,7 @@ renameInModule imports (Module modSS coms mn decls exps) = -> Qualified a -> SourceSpan -> m (Qualified a) - update imps toName qname@(Qualified mn' name) pos = warnAndRethrowWithPosition pos $ + update imps toName qname@(Qualified mn' name _) pos = warnAndRethrowWithPosition pos $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, @@ -424,7 +424,7 @@ renameInModule imports (Module modSS coms mn decls exps) = (mnNew, mnOrig) <- checkImportConflicts pos mn toName options modify $ \usedImports -> M.insertWith (++) mnNew [fmap toName qname] usedImports - return $ Qualified (ByModuleName mnOrig) name + return $ mkQualified_ (ByModuleName mnOrig) name -- If the name wasn't found in our imports but was qualified then we need -- to check whether it's a failed import from a "pseudo" module (created @@ -433,7 +433,7 @@ renameInModule imports (Module modSS coms mn decls exps) = (Nothing, ByModuleName mn'') -> if mn'' `S.member` importedQualModules imports || mn'' `S.member` importedModules imports then throwUnknown - else throwError . errorMessage . UnknownName . Qualified ByNullSourcePos $ ModName mn'' + else throwError . errorMessage . UnknownName . mkQualified_ ByNullSourcePos $ ModName mn'' -- If neither of the above cases are true then it's an undefined or -- unimported symbol. diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 2ab8b00d5c..c07483fc9c 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -37,7 +37,7 @@ import Language.PureScript.AST (ExportSource(..), SourceSpan, internalModuleSour import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') -import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual) +import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual, mkQualified_) -- | -- The details for an import: the name of the thing that is being imported @@ -229,11 +229,11 @@ mkPrimExports ts cs = , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys cs } where - mkTypeEntry (Qualified (ByModuleName mn) name) = (name, ([], primExportSource mn)) + mkTypeEntry (Qualified (ByModuleName mn) name _) = (name, ([], primExportSource mn)) mkTypeEntry _ = internalError "mkPrimExports.mkTypeEntry: a name is qualified BySourcePos instead of ByModuleName" - mkClassEntry (Qualified (ByModuleName mn) name) = (name, primExportSource mn) + mkClassEntry (Qualified (ByModuleName mn) name _) = (name, primExportSource mn) mkClassEntry _ = internalError "mkPrimExports.mkClassEntry: a name is qualified BySourcePos instead of ByModuleName" @@ -463,7 +463,7 @@ throwExportConflict' -> m a throwExportConflict' ss new existing newName existingName = throwError . errorMessage' ss $ - ExportConflict (Qualified (ByModuleName new) newName) (Qualified (ByModuleName existing) existingName) + ExportConflict (mkQualified_ (ByModuleName new) newName) (mkQualified_ (ByModuleName existing) existingName) -- | -- When reading a value from the imports, check that there are no conflicts in @@ -487,7 +487,7 @@ checkImportConflicts ss currentModule toName xs = in if length groups > 1 then case nonImplicit of - [ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _] -> do + [ImportRecord (Qualified (ByModuleName mnNew) _ _) mnOrig _ _] -> do let warningModule = if mnNew == currentModule then Nothing else Just mnNew ss' = maybe nullSourceSpan importSourceSpan . headMay . filter ((== FromImplicit) . importProvenance) $ xs tell . errorMessage' ss' $ ScopeShadowing name warningModule $ delete mnNew conflictModules @@ -495,7 +495,7 @@ checkImportConflicts ss currentModule toName xs = _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules else case head byOrig of - ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _ -> + ImportRecord (Qualified (ByModuleName mnNew) _ _) mnOrig _ _ -> return (mnNew, mnOrig) _ -> internalError "checkImportConflicts: ImportRecord should be qualified" diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index cbe273f828..c7fa732d70 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -170,7 +170,7 @@ resolveExports env ss mn imps exps refs = go :: Qualified (ProperName 'TypeName) -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ExportSource) - go (Qualified (ByModuleName mn'') name) = + go (Qualified (ByModuleName mn'') name _) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do exps' <- envModuleExports <$> mn'' `M.lookup` env (dctors', src) <- name `M.lookup` exportedTypes exps' @@ -179,7 +179,7 @@ resolveExports env ss mn imps exps refs = ( (name, relevantDctors `intersect` dctors') , src { exportSourceImportedFrom = Just mn'' } ) - go (Qualified _ _) = internalError "Unqualified value in resolveTypeExports" + go (Qualified _ _ _) = internalError "Unqualified value in resolveTypeExports" -- Looks up an imported type operator and re-qualifies it with the original -- module it came from. @@ -214,7 +214,7 @@ resolveExports env ss mn imps exps refs = => (Exports -> M.Map a ExportSource) -> Qualified a -> Maybe (a, ExportSource) - resolve f (Qualified (ByModuleName mn'') a) = do + resolve f (Qualified (ByModuleName mn'') a _) = do exps' <- envModuleExports <$> mn'' `M.lookup` env src <- a `M.lookup` f exps' return (a, src { exportSourceImportedFrom = Just mn'' }) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 3a43faf7fd..ee5c00badf 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -18,7 +18,7 @@ import Data.Set qualified as S import Language.PureScript.AST (Declaration(..), DeclarationRef(..), ErrorMessageHint(..), ExportSource(..), ImportDeclarationType(..), Module(..), SourceSpan, internalModuleSourceSpan) import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow) -import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName) +import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, mkQualified_) import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), envModuleExports, nullImports) type ImportDef = (SourceSpan, ImportDeclarationType, Maybe ModuleName) @@ -69,7 +69,7 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps go ie' (ss, typ, impQual) = do modExports <- maybe - (throwError . errorMessage' ss . UnknownName . Qualified ByNullSourcePos $ ModName mn) + (throwError . errorMessage' ss . UnknownName . mkQualified_ ByNullSourcePos $ ModName mn) (return . envModuleExports) (mn `M.lookup` env) let impModules = importedModules ie' @@ -221,9 +221,9 @@ resolveImport importModule exps imps impQual = resolveByType updateImports imps' exps' expName name ss prov = let src = maybe (internalError "Invalid state in updateImports") expName (name `M.lookup` exps') - rec = ImportRecord (Qualified (ByModuleName importModule) name) (exportSourceDefinedIn src) ss prov + rec = ImportRecord (mkQualified_ (ByModuleName importModule) name) (exportSourceDefinedIn src) ss prov in M.alter (\currNames -> Just $ rec : fromMaybe [] currNames) - (Qualified (byMaybeModuleName impQual) name) + (mkQualified_ (byMaybeModuleName impQual) name) imps' diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs index 88b93b899c..893b7d875a 100644 --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -14,7 +14,7 @@ import Data.Maybe (catMaybes) import Language.PureScript.AST import Language.PureScript.Environment (NameKind(..)) import Language.PureScript.Errors (MultipleErrors, rethrowWithPosition) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, Qualified(..), freshIdent') +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, freshIdent', mkQualified_) import Language.PureScript.PSString (PSString) @@ -98,4 +98,4 @@ desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d | otherwise = return Nothing argToExpr :: Ident -> Expr - argToExpr = Var nullSourceSpan . Qualified ByNullSourcePos + argToExpr = Var nullSourceSpan . mkQualified_ ByNullSourcePos diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 93028d7e22..c0b8963ebd 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -19,7 +19,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition) import Language.PureScript.Externs (ExternsFile(..), ExternsFixity(..), ExternsTypeFixity(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent') +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent', mkQualified_) import Language.PureScript.Sugar.Operators.Binders (matchBinderOperators) import Language.PureScript.Sugar.Operators.Expr (matchExprOperators) import Language.PureScript.Sugar.Operators.Types (matchTypeOperators) @@ -50,7 +50,7 @@ desugarSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts where (f', _, _) = everywhereOnValues id go id - go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.S_negate))) val + go (UnaryMinus ss' val) = App (Var ss' (mkQualified_ ByNullSourcePos (Ident C.S_negate))) val go other = other -- | @@ -150,10 +150,10 @@ rebracketFiltered !caller pred_ externs m = do goExpr _ e@(PositionedValue pos _ _) = return (pos, e) goExpr _ (Op pos op) = (pos,) <$> case op `M.lookup` valueAliased of - Just (Qualified mn' (Left alias)) -> - return $ Var pos (Qualified mn' alias) - Just (Qualified mn' (Right alias)) -> - return $ Constructor pos (Qualified mn' alias) + Just (Qualified mn' (Left alias) _) -> + return $ Var pos (mkQualified_ mn' alias) + Just (Qualified mn' (Right alias) _) -> + return $ Constructor pos (mkQualified_ mn' alias) Nothing -> throwError . errorMessage' pos . UnknownName $ fmap ValOpName op goExpr pos other = return (pos, other) @@ -162,10 +162,10 @@ rebracketFiltered !caller pred_ externs m = do goBinder _ b@(PositionedBinder pos _ _) = return (pos, b) goBinder _ (BinaryNoParensBinder (OpBinder pos op) lhs rhs) = case op `M.lookup` valueAliased of - Just (Qualified mn' (Left alias)) -> - throwError . errorMessage' pos $ InvalidOperatorInBinder op (Qualified mn' alias) - Just (Qualified mn' (Right alias)) -> - return (pos, ConstructorBinder pos (Qualified mn' alias) [lhs, rhs]) + Just (Qualified mn' (Left alias) _) -> + throwError . errorMessage' pos $ InvalidOperatorInBinder op (mkQualified_ mn' alias) + Just (Qualified mn' (Right alias) _) -> + return (pos, ConstructorBinder pos (mkQualified_ mn' alias) [lhs, rhs]) Nothing -> throwError . errorMessage' pos . UnknownName $ fmap ValOpName op goBinder _ BinaryNoParensBinder{} = @@ -254,9 +254,9 @@ removeBinaryNoParens u where err = throwError . errorMessage $ IncorrectAnonymousArgument removeBinaryNoParens (Parens (stripPositionInfo -> BinaryNoParens op l r)) | isAnonymousArgument r = do arg <- freshIdent' - return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (Qualified ByNullSourcePos arg)) + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (mkQualified_ ByNullSourcePos arg)) | isAnonymousArgument l = do arg <- freshIdent' - return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified ByNullSourcePos arg))) r + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (mkQualified_ ByNullSourcePos arg))) r removeBinaryNoParens (BinaryNoParens op l r) = return $ App (App op l) r removeBinaryNoParens e = return e @@ -303,7 +303,7 @@ externsFixities ExternsFile{..} = -> Either ValueFixityRecord TypeFixityRecord fromFixity (ExternsFixity assoc prec op name) = Left - ( Qualified (ByModuleName efModuleName) op + ( mkQualified_ (ByModuleName efModuleName) op , internalModuleSourceSpan "" , Fixity assoc prec , name @@ -314,7 +314,7 @@ externsFixities ExternsFile{..} = -> Either ValueFixityRecord TypeFixityRecord fromTypeFixity (ExternsTypeFixity assoc prec op name) = Right - ( Qualified (ByModuleName efModuleName) op + ( mkQualified_ (ByModuleName efModuleName) op , internalModuleSourceSpan "" , Fixity assoc prec , name @@ -325,9 +325,9 @@ collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord] collect (ValueFixityDeclaration (ss, _) fixity name op) = - [Left (Qualified (ByModuleName moduleName) op, ss, fixity, name)] + [Left (mkQualified_ (ByModuleName moduleName) op, ss, fixity, name)] collect (TypeFixityDeclaration (ss, _) fixity name op) = - [Right (Qualified (ByModuleName moduleName) op, ss, fixity, name)] + [Right (mkQualified_ (ByModuleName moduleName) op, ss, fixity, name)] collect _ = [] ensureNoDuplicates @@ -339,7 +339,7 @@ ensureNoDuplicates toError m = go $ sortOn fst m where go [] = return () go [_] = return () - go ((x@(Qualified (ByModuleName mn) op), _) : (y, pos) : _) | x == y = + go ((x@(Qualified (ByModuleName mn) op _), _) : (y, pos) : _) | x == y = rethrow (addHint (ErrorInModule mn)) $ rethrowWithPosition pos $ throwError . errorMessage $ toError op go (_ : rest) = go rest @@ -464,7 +464,7 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = getTypeOpAlias op = listToMaybe (mapMaybe (either (const Nothing) go <=< getFixityDecl) ds) where - go (TypeFixity _ (Qualified (ByModuleName mn') ident) op') + go (TypeFixity _ (Qualified (ByModuleName mn') ident _) op') | mn == mn' && op == op' = Just ident go _ = Nothing @@ -476,7 +476,7 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = getValueOpAlias op = listToMaybe (mapMaybe (either go (const Nothing) <=< getFixityDecl) ds) where - go (ValueFixity _ (Qualified (ByModuleName mn') ident) op') + go (ValueFixity _ (Qualified (ByModuleName mn') ident _) op') | mn == mn' && op == op' = Just ident go _ = Nothing diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index 29725c711a..622ad99e38 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -26,7 +26,7 @@ matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id extractOp _ = Nothing fromOp :: Binder -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName)) - fromOp (OpBinder ss q@(Qualified _ (OpName _))) = Just (ss, q) + fromOp (OpBinder ss q@(Qualified _ (OpName _) _)) = Just (ss, q) fromOp _ = Nothing reapply :: SourceSpan -> Qualified (OpName 'ValueOpName) -> Binder -> Binder -> Binder diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 0815eb1610..1a04896691 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -32,7 +32,7 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable extractOp _ = Nothing fromOp :: Expr -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName)) - fromOp (Op ss q@(Qualified _ (OpName _))) = Just (ss, q) + fromOp (Op ss q@(Qualified _ (OpName _) _)) = Just (ss, q) fromOp _ = Nothing reapply :: SourceSpan -> Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index 81001511cb..acb3cd8265 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -27,7 +27,7 @@ matchTypeOperators ss = matchOperators isBinOp extractOp fromOp reapply id extractOp _ = Nothing fromOp :: SourceType -> Maybe (SourceSpan, Qualified (OpName 'TypeOpName)) - fromOp (TypeOp _ q@(Qualified _ (OpName _))) = Just (ss, q) + fromOp (TypeOp _ q@(Qualified _ (OpName _) _)) = Just (ss, q) fromOp _ = Nothing reapply :: a -> Qualified (OpName 'TypeOpName) -> SourceType -> SourceType -> SourceType diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 4f3129baf8..54d86e68ab 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -30,7 +30,7 @@ import Language.PureScript.Environment (DataDeclType(..), NameKind(..), TypeClas import Language.PureScript.Errors hiding (isExported, nonEmpty) import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent, mkQualified_) import Language.PureScript.PSString (mkString) import Language.PureScript.Sugar.CaseDeclarations (desugarCases) import Language.PureScript.TypeClassDictionaries (superclassName) @@ -101,7 +101,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do constraintName (Constraint _ cName _ _ _) = cName classDeclName :: Declaration -> Qualified (ProperName 'ClassName) - classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (ByModuleName name) pn + classDeclName (TypeClassDeclaration _ pn _ _ _ _) = mkQualified_ (ByModuleName name) pn classDeclName _ = internalError "Expected TypeClassDeclaration" desugarModule _ = internalError "Exports should have been elaborated in name desugaring" @@ -250,7 +250,7 @@ desugarDecl mn exps = go :: (ProperName a -> [DeclarationRef] -> Bool) -> Qualified (ProperName a) -> Bool - isExported test (Qualified (ByModuleName mn') pn) = mn /= mn' || test pn exps + isExported test (Qualified (ByModuleName mn') pn _) = mn /= mn' || test pn exps isExported _ _ = internalError "Names should have been qualified in name desugaring" matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool @@ -296,15 +296,15 @@ typeClassMemberToDictionaryAccessor -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa@(ss, _) ident ty)) = - let className = Qualified (ByModuleName mn) name + let className = mkQualified_ (ByModuleName mn) name dictIdent = Ident "dict" dictObjIdent = Ident "v" ctor = ConstructorBinder ss (coerceProperName . dictTypeName <$> className) [VarBinder ss dictObjIdent] - acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified ByNullSourcePos dictObjIdent)) + acsr = Accessor (mkString $ runIdent ident) (Var ss (mkQualified_ ByNullSourcePos dictObjIdent)) visibility = second (const TypeVarVisible) <$> args in ValueDecl sa ident Private [] [MkUnguarded ( - TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ + TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ mkQualified_ ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ addVisibility visibility (moveQuantifiersToFront NullSourceAnn (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty))) )] typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index 9ef751e130..9e0837728f 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -13,7 +13,7 @@ import Language.PureScript.Constants.Libs qualified as Libs import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), NameKind(..)) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage') -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent, runProperName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), QualifiedBy(..), freshIdent, runProperName, mkQualified_) import Language.PureScript.PSString (mkString) import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString) import Language.PureScript.TypeChecker (checkNewtype) @@ -83,13 +83,13 @@ deriveGenericRep ss mn tyCon tyConArgs = lamCase x [ CaseAlternative [NullBinder] - (unguarded (App (Var ss Libs.I_to) (Var ss' (Qualified ByNullSourcePos x)))) + (unguarded (App (Var ss Libs.I_to) (Var ss' (mkQualified_ ByNullSourcePos x)))) ] , ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] - (unguarded (App (Var ss Libs.I_from) (Var ss' (Qualified ByNullSourcePos x)))) + (unguarded (App (Var ss Libs.I_from) (Var ss' (mkQualified_ ByNullSourcePos x)))) ] ] | otherwise = @@ -132,8 +132,8 @@ deriveGenericRep ss mn tyCon tyConArgs = (srcTypeLevelString $ mkString (runProperName ctorName))) ctorTy , CaseAlternative [ ConstructorBinder ss Libs.C_Constructor [matchProduct] ] - (unguarded (foldl' App (Constructor ss (Qualified (ByModuleName mn) ctorName)) ctorArgs)) - , CaseAlternative [ ConstructorBinder ss (Qualified (ByModuleName mn) ctorName) matchCtor ] + (unguarded (foldl' App (Constructor ss (mkQualified_ (ByModuleName mn) ctorName)) ctorArgs)) + , CaseAlternative [ ConstructorBinder ss (mkQualified_ (ByModuleName mn) ctorName) matchCtor ] (unguarded (App (Constructor ss Libs.C_Constructor) mkProduct)) ) @@ -156,9 +156,9 @@ deriveGenericRep ss mn tyCon tyConArgs = argName <- freshIdent "arg" pure ( srcTypeApp (srcTypeConstructor Libs.Argument) arg , ConstructorBinder ss Libs.C_Argument [ VarBinder ss argName ] - , Var ss (Qualified (BySourcePos $ spanStart ss) argName) + , Var ss (mkQualified_ (BySourcePos $ spanStart ss) argName) , VarBinder ss argName - , App (Constructor ss Libs.C_Argument) (Var ss (Qualified (BySourcePos $ spanStart ss) argName)) + , App (Constructor ss Libs.C_Argument) (Var ss (mkQualified_ (BySourcePos $ spanStart ss) argName)) ) underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index fd4e7c7982..08c015ae42 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -35,7 +35,7 @@ import Language.PureScript.Environment (DataDeclType(..), Environment(..), Funct import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, errorMessage', positionedError, rethrow, warnAndRethrow, MultipleErrors) import Language.PureScript.Linter (checkExhaustiveExpr) import Language.PureScript.Linter.Wildcards (ignoreWildcardsUnderCompleteTypeSignatures) -import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified) +import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified, mkQualified_) import Language.PureScript.Roles (Role) import Language.PureScript.Sugar.Names.Env (Exports(..)) import Language.PureScript.TypeChecker.Kinds as T @@ -58,7 +58,7 @@ addDataType addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) - qualName = Qualified (ByModuleName moduleName) name + qualName = mkQualified_ (ByModuleName moduleName) name hasSig = qualName `M.member` types env putEnv $ env { types = M.insert qualName (ctorKind, DataType dtype args (map (mapDataCtor . fst) dctors)) (types env) } unless (hasSig || isDictTypeName name || not (containsForAll ctorKind)) $ do @@ -79,7 +79,7 @@ addDataConstructor moduleName dtype name dctor dctorArgs polyType = do let fields = fst <$> dctorArgs env <- getEnv checkTypeSynonyms polyType - putEnv $ env { dataConstructors = M.insert (Qualified (ByModuleName moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } + putEnv $ env { dataConstructors = M.insert (mkQualified_ (ByModuleName moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } checkRoleDeclaration :: ModuleName @@ -88,7 +88,7 @@ checkRoleDeclaration checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles) = do warnAndRethrow (addHint (ErrorInRoleDeclaration name) . addHint (positionedError ss)) $ do env <- getEnv - let qualName = Qualified (ByModuleName moduleName) name + let qualName = mkQualified_ (ByModuleName moduleName) name case M.lookup qualName (types env) of Just (kind, DataType dtype args dctors) -> do checkRoleDeclarationArity name declaredRoles (length args) @@ -110,7 +110,7 @@ addTypeSynonym addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty - let qualName = Qualified (ByModuleName moduleName) name + let qualName = mkQualified_ (ByModuleName moduleName) name hasSig = qualName `M.member` types env unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration TypeSynonymSig name kind @@ -123,7 +123,7 @@ valueIsNotDefined -> TypeCheckM () valueIsNotDefined moduleName name = do env <- getEnv - case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of + case M.lookup (mkQualified_ (ByModuleName moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> return () @@ -135,7 +135,7 @@ addValue -> TypeCheckM () addValue moduleName name ty nameKind = do env <- getEnv - putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (ty, nameKind, Defined) (names env) }) + putEnv (env { names = M.insert (mkQualified_ (ByModuleName moduleName) name) (ty, nameKind, Defined) (names env) }) addTypeClass :: ModuleName @@ -281,7 +281,7 @@ typeCheckAll moduleName = traverse go addDataType moduleName dtype name args'' dataCtors ctorKind for_ roleDecls $ checkRoleDeclaration moduleName for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do - let qualifiedClassName = Qualified (ByModuleName moduleName) pn + let qualifiedClassName = mkQualified_ (ByModuleName moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn (fst sa))) $ not (M.member qualifiedClassName (typeClasses env)) addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind @@ -306,7 +306,7 @@ typeCheckAll moduleName = traverse go warnAndRethrow (addHint (ErrorInKindDeclaration name) . addHint (positionedError ss)) $ do elabTy <- withFreshSubstitution $ checkKindDeclaration moduleName ty env <- getEnv - putEnv $ env { types = M.insert (Qualified (ByModuleName moduleName) name) (elabTy, LocalTypeVariable) (types env) } + putEnv $ env { types = M.insert (mkQualified_ (ByModuleName moduleName) name) (elabTy, LocalTypeVariable) (types env) } return $ KindDeclaration sa kindFor name elabTy go d@(RoleDeclaration rdd) = do checkRoleDeclaration moduleName rdd @@ -345,7 +345,7 @@ typeCheckAll moduleName = traverse go warnAndRethrow (addHint (ErrorInForeignImportData name) . addHint (positionedError ss)) $ do elabKind <- withFreshSubstitution $ checkKindDeclaration moduleName kind env <- getEnv - let qualName = Qualified (ByModuleName moduleName) name + let qualName = mkQualified_ (ByModuleName moduleName) name roles = nominalRolesForKind elabKind putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) } return d @@ -357,16 +357,16 @@ typeCheckAll moduleName = traverse go ty'' <- varIfUnknown unks ty' pure (ty'', kind) checkTypeKind elabTy kind - case M.lookup (Qualified (ByModuleName moduleName) name) (names env) of + case M.lookup (mkQualified_ (ByModuleName moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name - Nothing -> putEnv (env { names = M.insert (Qualified (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) }) + Nothing -> putEnv (env { names = M.insert (mkQualified_ (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) }) return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d go d@(TypeClassDeclaration sa@(ss, _) pn args implies deps tys) = do warnAndRethrow (addHint (ErrorInTypeClassDeclaration pn) . addHint (positionedError ss)) $ do env <- getEnv - let qualifiedClassName = Qualified (ByModuleName moduleName) pn + let qualifiedClassName = mkQualified_ (ByModuleName moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn ss)) $ not (M.member qualifiedClassName (typeClasses env)) (args', implies', tys', kind) <- kindOfClass moduleName (sa, pn, args, implies, tys) @@ -376,7 +376,7 @@ typeCheckAll moduleName = traverse go go d@(TypeInstanceDeclaration sa@(ss, _) _ ch idx (Right dictName) deps className tys body) = rethrow (addHint (ErrorInInstance className tys) . addHint (positionedError ss)) $ do env <- getEnv - let qualifiedDictName = Qualified (ByModuleName moduleName) dictName + let qualifiedDictName = mkQualified_ (ByModuleName moduleName) dictName flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> guardWith (errorMessage (DuplicateInstance dictName ss)) $ not (M.member qualifiedDictName dictionaries) @@ -428,7 +428,7 @@ typeCheckAll moduleName = traverse go -> TypeClassData -> [SourceType] -> S.Set ModuleName - findNonOrphanModules (Qualified (ByModuleName mn') _) typeClass tys' = nonOrphanModules + findNonOrphanModules (Qualified (ByModuleName mn') _ _) typeClass tys' = nonOrphanModules where nonOrphanModules :: S.Set ModuleName nonOrphanModules = S.insert mn' nonOrphanModules' @@ -437,8 +437,8 @@ typeCheckAll moduleName = traverse go typeModule (TypeVar _ _) = Nothing typeModule (TypeLevelString _ _) = Nothing typeModule (TypeLevelInt _ _) = Nothing - typeModule (TypeConstructor _ (Qualified (ByModuleName mn'') _)) = Just mn'' - typeModule (TypeConstructor _ (Qualified (BySourcePos _) _)) = internalError "Unqualified type name in findNonOrphanModules" + typeModule (TypeConstructor _ (Qualified (ByModuleName mn'') _ _)) = Just mn'' + typeModule (TypeConstructor _ (Qualified (BySourcePos _) _ _)) = internalError "Unqualified type name in findNonOrphanModules" typeModule (TypeApp _ t1 _) = typeModule t1 typeModule (KindApp _ t1 _) = typeModule t1 typeModule (KindedType _ t1 _) = typeModule t1 @@ -480,7 +480,7 @@ typeCheckAll moduleName = traverse go for_ nonOrphanModules $ \m -> do dicts <- M.toList <$> lookupTypeClassDictionariesForClass (ByModuleName m) className - for_ dicts $ \(Qualified mn' ident, dictNel) -> do + for_ dicts $ \(Qualified mn' ident _, dictNel) -> do for_ dictNel $ \dict -> do -- ignore instances in the same instance chain if ch == tcdChain dict || @@ -488,11 +488,11 @@ typeCheckAll moduleName = traverse go then return () else do let this = if isPlainIdent dictName then Right dictName else Left $ srcInstanceType ss vars className tys' - let that = Qualified mn' . maybeToLeft ident $ tcdDescription dict + let that = mkQualified_ mn' . maybeToLeft ident $ tcdDescription dict throwError . errorMessage $ OverlappingInstances className tys' - [that, Qualified (ByModuleName moduleName) this] + [that, mkQualified_ (ByModuleName moduleName) this] instancesAreApart :: S.Set (S.Set Int) @@ -608,13 +608,13 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = ImportDeclaration sa moduleName importDeclarationType asModuleName qualify' :: a -> Qualified a - qualify' = Qualified (ByModuleName mn) + qualify' = mkQualified_ (ByModuleName mn) getSuperClassExportCheck = do classesToSuperClasses <- gets ( M.map ( S.fromList - . filter (\(Qualified mn' _) -> mn' == ByModuleName mn) + . filter (\(Qualified mn' _ _) -> mn' == ByModuleName mn) . fmap constraintClass . typeClassSuperclasses ) @@ -710,7 +710,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = findTcons :: SourceType -> [DeclarationRef] findTcons = everythingOnTypes (++) go where - go (TypeConstructor _ (Qualified (ByModuleName mn') name)) | mn' == mn = + go (TypeConstructor _ (Qualified (ByModuleName mn') name _)) | mn' == mn = [TypeRef (declRefSourceSpan ref) name (internalError "Data constructors unused in checkTypesAreExported")] go _ = [] @@ -725,7 +725,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = go (ConstrainedType _ c _) = (fmap (TypeClassRef (declRefSourceSpan ref)) . extractCurrentModuleClass . constraintClass) c go _ = [] extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName] - extractCurrentModuleClass (Qualified (ByModuleName mn') name) | mn == mn' = [name] + extractCurrentModuleClass (Qualified (ByModuleName mn') name _) | mn == mn' = [name] extractCurrentModuleClass _ = [] checkClassMembersAreExported :: DeclarationRef -> TypeCheckM () @@ -767,7 +767,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = isDictOfTypeRef :: TypeClassDictionaryInScope a -> Bool isDictOfTypeRef dict | (TypeConstructor _ qualTyName, _, _) : _ <- unapplyTypes <$> tcdInstanceTypes dict - , qualTyName == Qualified (ByModuleName mn) name + , qualTyName == mkQualified_ (ByModuleName mn) name = True isDictOfTypeRef _ = False getDataConstructorNames :: TypeKind -> Maybe [ProperName 'ConstructorName] diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index dcd662f8a5..2a1349e411 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -23,7 +23,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>)) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString, mkQualified_) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames) import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts) @@ -169,7 +169,7 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs -- newtype-derived; see #3168. The whole verifySuperclasses feature -- is pretty sketchy, and could use a thorough review and probably rewrite. hasNewtypeSuperclassInstance (suModule, suClass) nt@(newtypeModule, _) dicts = - let su = Qualified (ByModuleName suModule) suClass + let su = mkQualified_ (ByModuleName suModule) suClass lookIn mn' = elem nt . (toList . extractNewtypeName mn' . tcdInstanceTypes @@ -339,11 +339,11 @@ lookupTypeDecl lookupTypeDecl mn typeName = do env <- getEnv note (errorMessage $ CannotFindDerivingType typeName) $ do - (kind, DataType _ args dctors) <- Qualified (ByModuleName mn) typeName `M.lookup` types env + (kind, DataType _ args dctors) <- mkQualified_ (ByModuleName mn) typeName `M.lookup` types env (kargs, _) <- completeBinderList kind let dtype = do (ctorName, _) <- headMay dctors - (a, _, _, _) <- Qualified (ByModuleName mn) ctorName `M.lookup` dataConstructors env + (a, _, _, _) <- mkQualified_ (ByModuleName mn) ctorName `M.lookup` dataConstructors env pure a pure (dtype, fst . snd <$> kargs, map (\(v, k, _) -> (v, k)) args, dctors) @@ -502,7 +502,7 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con lparamIsContra = any lparamIsContravariant contravarianceSupport hasInstance :: InstanceContext -> Qualified (Either Text (ProperName 'TypeName)) -> Qualified (ProperName 'ClassName) -> Bool - hasInstance tcds ht@(Qualified qb _) cn@(Qualified cqb _) = + hasInstance tcds ht@(Qualified qb _ _) cn@(Qualified cqb _ _) = any tcdAppliesToType $ concatMap (findDicts tcds cn) (ordNub [ByNullSourcePos, cqb, qb]) where tcdAppliesToType tcd = case tcdInstanceTypes tcd of @@ -517,9 +517,9 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con headOfType = fix $ \go -> \case TypeApp _ ty _ -> go ty KindApp _ ty _ -> go ty - TypeVar _ nm -> Qualified ByNullSourcePos (Left nm) - Skolem _ nm _ _ _ -> Qualified ByNullSourcePos (Left nm) - TypeConstructor _ (Qualified qb nm) -> Qualified qb (Right nm) + TypeVar _ nm -> mkQualified_ ByNullSourcePos (Left nm) + Skolem _ nm _ _ _ -> mkQualified_ ByNullSourcePos (Left nm) + TypeConstructor _ (Qualified qb nm h) -> Qualified qb (Right nm) h ty -> internalError $ "headOfType missing a case: " <> show (void ty) usingLamIdent :: (Expr -> TypeCheckM Expr) -> TypeCheckM Expr diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 225f2737fb..0779995d70 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -39,7 +39,7 @@ import Language.PureScript.AST.Declarations (UnknownsHint(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName, mkQualified_) import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds) import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation) import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') @@ -217,12 +217,12 @@ entails SolverOptions{..} constraint context hints = forClassName _ _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts forClassName _ _ C.RowCons kinds args | Just dicts <- solveRowCons kinds args = dicts forClassName _ _ C.RowToList kinds args | Just dicts <- solveRowToList kinds args = dicts - forClassName _ ctx cn@(Qualified (ByModuleName mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys))) + forClassName _ ctx cn@(Qualified (ByModuleName mn) _ _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys))) forClassName _ _ _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: SourceType -> Maybe ModuleName - ctorModules (TypeConstructor _ (Qualified (ByModuleName mn) _)) = Just mn - ctorModules (TypeConstructor _ (Qualified (BySourcePos _) _)) = internalError "ctorModules: unqualified type name" + ctorModules (TypeConstructor _ (Qualified (ByModuleName mn) _ _)) = Just mn + ctorModules (TypeConstructor _ (Qualified (BySourcePos _) _ _)) = internalError "ctorModules: unqualified type name" ctorModules (TypeApp _ ty _) = ctorModules ty ctorModules (KindApp _ ty _) = ctorModules ty ctorModules (KindedType _ ty _) = ctorModules ty @@ -311,7 +311,7 @@ entails SolverOptions{..} constraint context hints = Unsolved unsolved -> do -- Generate a fresh name for the unsolved constraint's new dictionary ident <- freshIdent ("dict" <> runProperName (disqualify (constraintClass unsolved))) - let qident = Qualified ByNullSourcePos ident + let qident = mkQualified_ ByNullSourcePos ident -- Store the new dictionary in the InstanceContext so that we can solve this goal in -- future. newDicts <- lift . lift $ newDictionaries [] qident unsolved @@ -376,7 +376,7 @@ entails SolverOptions{..} constraint context hints = tcdToInstanceDescription TypeClassDictionaryInScope{ tcdDescription, tcdValue } = let nii = namedInstanceIdentifier tcdValue in case tcdDescription of - Just ty -> flip Qualified (Left ty) <$> fmap (byMaybeModuleName . getQual) nii + Just ty -> flip mkQualified_ (Left ty) <$> fmap (byMaybeModuleName . getQual) nii Nothing -> fmap Right <$> nii canBeGeneralized :: Type a -> Bool @@ -441,7 +441,7 @@ entails SolverOptions{..} constraint context hints = where -- Only keep type class members that need VTAs to resolve their type class instances qualifyAndFilter (ident, _, mbVtaRequiredArgs) = mbVtaRequiredArgs <&> \vtaRequiredArgs -> - (Qualified (ByModuleName tyClassModuleName) ident, map (map indexToArgText . NEL.toList) $ S.toList vtaRequiredArgs) + (mkQualified_ (ByModuleName tyClassModuleName) ident, map (map indexToArgText . NEL.toList) $ S.toList vtaRequiredArgs) tyClassMembersInExpr :: Expr -> [(Qualified Ident, [[Text]])] tyClassMembersInExpr = getVars diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 18826f3a40..898d715617 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -38,7 +38,7 @@ import Data.Set qualified as S import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds) import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..)) -import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName) +import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName, mkQualified_) import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds') import Language.PureScript.TypeChecker.Monad (CheckState(..), TypeCheckM) import Language.PureScript.TypeChecker.Roles (lookupRoles) @@ -672,7 +672,7 @@ lookupNewtypeConstructorInScope -> Qualified (ProperName 'TypeName) -> [SourceType] -> Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType) -lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do +lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName _) ks = do let fromModule = find isNewtypeCtorImported currentModuleImports fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule asModuleName = (\(_, _, _, n, _) -> n) =<< fromModule @@ -680,7 +680,7 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali isImported = isJust fromModule inScope = isDefinedInCurrentModule || isImported (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName ks - pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy) + pure (inScope, fromModuleName, tvs, mkQualified_ (byMaybeModuleName asModuleName) ctorName, wrappedTy) where isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) = case M.lookup newtypeName exportedTypes of diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index d0e707ec5f..2e4884625f 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -51,7 +51,7 @@ import Data.Traversable (for) import Language.PureScript.Crash (HasCallStack, internalError) import Language.PureScript.Environment qualified as E import Language.PureScript.Errors -import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified, runProperName, properNameFromString) +import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified, runProperName, properNameFromString, mkQualified_) import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) @@ -190,7 +190,7 @@ inferKind = \tyToInfer -> pure (ty, E.tyInt $> ann) ty@(TypeVar ann v) -> do moduleName <- unsafeCheckCurrentModule - kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ properNameFromString v) + kind <- apply =<< lookupTypeVariable moduleName (mkQualified_ ByNullSourcePos $ properNameFromString v) pure (ty, kind $> ann) ty@(Skolem ann _ mbK _ _) -> do kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK @@ -529,7 +529,7 @@ elaborateKind = \case ($> ann) <$> apply kind TypeVar ann a -> do moduleName <- unsafeCheckCurrentModule - kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ properNameFromString a) + kind <- apply =<< lookupTypeVariable moduleName (mkQualified_ ByNullSourcePos $ properNameFromString a) pure (kind $> ann) (Skolem ann _ mbK _ _) -> do kind <- apply $ fromMaybe (internalError "Skolem has no kind") mbK @@ -641,7 +641,7 @@ inferDataDeclaration -> DataDeclarationArgs -> TypeCheckM [(DataConstructorDeclaration, SourceType)] inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do - tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) + tyKind <- apply =<< lookupTypeVariable moduleName (mkQualified_ ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind bindLocalTypeVariables moduleName (first properNameFromString . snd <$> sigBinders) $ do tyArgs' <- for tyArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType @@ -693,7 +693,7 @@ inferTypeSynonym -> TypeDeclarationArgs -> TypeCheckM SourceType inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do - tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) + tyKind <- apply =<< lookupTypeVariable moduleName (mkQualified_ ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind bindLocalTypeVariables moduleName (first properNameFromString . snd <$> sigBinders) $ do kindRes <- freshKind (fst ann) @@ -810,7 +810,7 @@ inferClassDeclaration -> ClassDeclarationArgs -> TypeCheckM ([(Text, SourceType)], [SourceConstraint], [Declaration]) inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = do - clsKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ coerceProperName clsName) + clsKind <- apply =<< lookupTypeVariable moduleName (mkQualified_ ByNullSourcePos $ coerceProperName clsName) let (sigBinders, clsKind') = fromJust . completeBinderList $ clsKind bindLocalTypeVariables moduleName (first properNameFromString. snd <$> sigBinders) $ do clsArgs' <- for clsArgs . traverse . maybe (freshKind (fst ann)) $ replaceAllTypeSynonyms <=< apply <=< checkIsSaturatedType @@ -941,7 +941,7 @@ existingSignatureOrFreshKind -> TypeCheckM SourceType existingSignatureOrFreshKind moduleName ss name = do env <- getEnv - case M.lookup (Qualified (ByModuleName moduleName) name) (E.types env) of + case M.lookup (mkQualified_ (ByModuleName moduleName) name) (E.types env) of Nothing -> freshKind ss Just (kind, _) -> pure kind diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 729308ae7c..5c725fe896 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -24,7 +24,7 @@ import Data.List.NonEmpty qualified as NEL import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..)) import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition) -import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString) +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString, mkQualified_) import Language.PureScript.Pretty.Types (prettyPrintType) import Language.PureScript.Pretty.Values (prettyPrintValue) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) @@ -175,9 +175,9 @@ withScopedTypeVars withScopedTypeVars mn ks ma = do orig <- get forM_ ks $ \(name, _) -> - when (Qualified (ByModuleName mn) (properNameFromString name) `M.member` types (checkEnv orig)) $ + when (mkQualified_ (ByModuleName mn) (properNameFromString name) `M.member` types (checkEnv orig)) $ tell . errorMessage $ ShadowedTypeVar name - bindTypes (M.fromList (map (\(name, k) -> (Qualified (ByModuleName mn) (properNameFromString name), (k, ScopedTypeVar))) ks)) ma + bindTypes (M.fromList (map (\(name, k) -> (mkQualified_ (ByModuleName mn) (properNameFromString name), (k, ScopedTypeVar))) ks)) ma withErrorMessageHint :: (MonadState CheckState m, MonadError MultipleErrors m) @@ -220,7 +220,7 @@ withTypeClassDictionaries entries action = do let mentries = M.fromListWith (M.unionWith (M.unionWith (<>))) [ (qb, M.singleton className (M.singleton tcdValue (pure entry))) - | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className } + | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _ _), tcdClassName = className } <- entries ] @@ -253,7 +253,7 @@ bindLocalVariables -> TypeCheckM a -> TypeCheckM a bindLocalVariables bindings = - bindNames (M.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (Qualified (BySourcePos $ spanStart ss) name, (ty, Private, visibility))) + bindNames (M.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (mkQualified_ (BySourcePos $ spanStart ss) name, (ty, Private, visibility))) -- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables @@ -262,7 +262,7 @@ bindLocalTypeVariables -> TypeCheckM a -> TypeCheckM a bindLocalTypeVariables moduleName bindings = - bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) + bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (mkQualified_ (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) -- | Update the visibility of all names to Defined makeBindingGroupVisible :: TypeCheckM () @@ -304,7 +304,7 @@ getVisibility qual = do checkVisibility :: Qualified Ident -> TypeCheckM () -checkVisibility name@(Qualified _ var) = do +checkVisibility name@(Qualified _ var _) = do vis <- getVisibility name case vis of Undefined -> throwError . errorMessage $ CycleInDeclaration var @@ -315,9 +315,9 @@ lookupTypeVariable :: ModuleName -> Qualified (ProperName 'TypeName) -> TypeCheckM SourceType -lookupTypeVariable currentModule (Qualified qb name) = do +lookupTypeVariable currentModule (Qualified qb name _) = do env <- getEnv - case M.lookup (Qualified qb' name) (types env) of + case M.lookup (mkQualified_ qb' name) (types env) of Nothing -> throwError . errorMessage $ UndefinedTypeVariable name Just (k, _) -> return k where @@ -333,7 +333,7 @@ getEnv = gets checkEnv getLocalContext :: TypeCheckM Context getLocalContext = do env <- getEnv - return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ] + return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{} _, (ty', _, Defined)) <- M.toList (names env) ] -- | Update the @Environment@ putEnv :: Environment -> TypeCheckM () diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index 7b38a317b7..c4b146b0d0 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -26,7 +26,7 @@ import Data.Text (Text) import Language.PureScript.Environment (Environment(..), TypeKind(..)) import Language.PureScript.Errors (DataConstructorDeclaration(..), MultipleErrors, RoleDeclarationData(..), SimpleErrorMessage(..), errorMessage) -import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..)) +import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), mkQualified_) import Language.PureScript.Roles (Role(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), freeTypeVariables, unapplyTypes) @@ -140,12 +140,12 @@ inferDataBindingGroupRoles -> [(Text, Maybe SourceType)] -> [Role] inferDataBindingGroupRoles env moduleName roleDeclarations group = - let declaredRoleEnv = M.fromList $ map (Qualified (ByModuleName moduleName) . rdeclIdent &&& rdeclRoles) roleDeclarations + let declaredRoleEnv = M.fromList $ map (mkQualified_ (ByModuleName moduleName) . rdeclIdent &&& rdeclRoles) roleDeclarations inferredRoleEnv = getRoleEnv env initialRoleEnv = declaredRoleEnv `M.union` inferredRoleEnv inferredRoleEnv' = inferDataBindingGroupRoles' moduleName group initialRoleEnv in \tyName tyArgs -> - let qualTyName = Qualified (ByModuleName moduleName) tyName + let qualTyName = mkQualified_ (ByModuleName moduleName) tyName inferredRoles = M.lookup qualTyName inferredRoleEnv' in fromMaybe (Phantom <$ tyArgs) inferredRoles @@ -177,7 +177,7 @@ inferDataDeclarationRoles -> RoleEnv -> (Any, RoleEnv) inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = - let qualTyName = Qualified (ByModuleName moduleName) tyName + let qualTyName = mkQualified_ (ByModuleName moduleName) tyName ctorRoles = getRoleMap . foldMap (walk mempty . snd) $ ctors >>= dataCtorFields inferredRoles = map (\(arg, _) -> fromMaybe Phantom (M.lookup arg ctorRoles)) tyArgs in updateRoleEnv qualTyName inferredRoles roleEnv diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index e8812a5439..e089dc31d1 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -66,7 +66,7 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do userT' <- initializeSkolems userT envT' <- initializeSkolems envT - let dummyExpression = P.Var nullSourceSpan (P.Qualified P.ByNullSourcePos (P.Ident "x")) + let dummyExpression = P.Var nullSourceSpan (P.mkQualified_ P.ByNullSourcePos (P.Ident "x")) elab <- subsumes envT' userT' subst <- gets TC.checkSubstitution @@ -131,10 +131,10 @@ typeSearch unsolved env st type' = matchingConstructors = runTypeSearch (Map.map (\(_, _, ty, _) -> ty) (P.dataConstructors env)) (allLabels, matchingLabels) = accessorSearch unsolved env st type' - runPlainIdent (Qualified m (Ident k), v) = Just (Qualified m k, v) + runPlainIdent (Qualified m (Ident k) h, v) = Just (Qualified m k h, v) runPlainIdent _ = Nothing in - ( (first (P.Qualified P.ByNullSourcePos . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) + ( (first (P.mkQualified_ P.ByNullSourcePos . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) <> mapMaybe runPlainIdent (Map.toList matchingNames) <> (first (map P.runProperName) <$> Map.toList matchingConstructors) , if null allLabels then Nothing else Just allLabels) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e25f470297..f1dfd34c63 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -50,7 +50,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent, properNameFromString, runProperName) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent, properNameFromString, runProperName, mkQualified_) import Language.PureScript.TypeChecker.Deriving (deriveInstance) import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) @@ -266,7 +266,7 @@ typeDictionaryForBindingGroup moduleName vals = do return ((sai, ty), (sai, (expr, ty))) -- Create the dictionary of all name/type pairs, which will be added to the -- environment during type checking - let dict = M.fromList [ (Qualified (maybe (BySourcePos $ spanStart ss) ByModuleName moduleName) ident, (ty, Private, Undefined)) + let dict = M.fromList [ (mkQualified_ (maybe (BySourcePos $ spanStart ss) ByModuleName moduleName) ident, (ty, Private, Undefined)) | (((ss, _), ident), ty) <- typedDict <> untypedDict ] return (SplitBindingGroup untyped' typed' dict) @@ -585,20 +585,20 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (Typed TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do ((args, elabTy), kind) <- kindOfWithScopedVars ty checkTypeKind ty kind - let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) + let dict = M.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return (TypedValue' checkType val elabTy) - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) + bindNames (M.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do valTy <- freshTypeWithKind kindType TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do - let dict = M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) + let dict = M.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) bindNames dict $ infer val warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' - bindNames (M.singleton (Qualified (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) + bindNames (M.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do moduleName <- unsafeCheckCurrentModule @@ -776,17 +776,17 @@ check' val (ForAll ann vis ident mbK ty _) = do -- an undefined type variable that happens to clash with the variable we -- want to skolemize. This can happen due to synonym expansion (see 2542). skVal - | Just _ <- M.lookup (Qualified (byMaybeModuleName mn) (properNameFromString ident)) $ types env = + | Just _ <- M.lookup (mkQualified_ (byMaybeModuleName mn) (properNameFromString ident)) $ types env = skolemizeTypesInValue ss ident mbK sko scope val | otherwise = val val' <- tvToExpr <$> check skVal sk return $ TypedValue' True val' (ForAll ann vis ident mbK ty (Just scope)) -check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ className) _ _ _) ty) = do +check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ className _) _ _ _) ty) = do TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls -- An empty class dictionary is never used; see code in `TypeChecker.Entailment` -- that wraps empty dictionary solutions in `Unused`. dictName <- if typeClassIsEmpty then pure UnusedIdent else freshIdent ("dict" <> runProperName className) - dicts <- newDictionaries [] (Qualified ByNullSourcePos dictName) con + dicts <- newDictionaries [] (mkQualified_ ByNullSourcePos dictName) con val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty return $ TypedValue' True (Abs (VarBinder nullSourceSpan dictName) (tvToExpr val')) t check' val u@(TUnknown _ _) = do @@ -1021,7 +1021,7 @@ isInternal :: Expr -> Bool isInternal = \case PositionedValue _ _ v -> isInternal v TypedValue _ v _ -> isInternal v - Constructor _ (Qualified _ name) -> isDictTypeName name + Constructor _ (Qualified _ name _) -> isDictTypeName name DerivedInstancePlaceholder{} -> True _ -> False diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs index 8604ed3b48..d3c4920e14 100644 --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -21,8 +21,8 @@ moduleD = (P.moduleNameFromString "Module.D", [T.ideType "kind1" Nothing []]) moduleE = (P.moduleNameFromString "Module.E", [T.ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS]) moduleF = (P.moduleNameFromString "Module.F", [T.ideDtor "DtorA" "TypeA" Nothing]) moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindType []]) -moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified P.ByNullSourcePos (Left "")) 0 Nothing Nothing]) -moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified P.ByNullSourcePos "") 0 Nothing Nothing]) +moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.mkQualified_ P.ByNullSourcePos (Left "")) 0 Nothing Nothing]) +moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.mkQualified_ P.ByNullSourcePos "") 0 Nothing Nothing]) moduleDCtors = (P.moduleNameFromString "Module.WithDC", [T.ideType "Foo" Nothing [(P.ProperName "A", P.tyString), (P.ProperName "B", P.tyString)] ]) modules :: ModuleMap [IdeDeclarationAnn] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index b12aeea352..6e03a28e92 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -114,7 +114,7 @@ spec = do addValueImport i mn q is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValue i Nothing)) mn q is) addOpImport op mn q is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.Qualified (P.byMaybeModuleName q) (Left "")) 2 Nothing Nothing)) mn q is) + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideValueOp op (P.mkQualified_ (P.byMaybeModuleName q) (Left "")) 2 Nothing Nothing)) mn q is) addDtorImport i t mn q is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn q is) addTypeImport i mn q is = diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index f7de445c0e..a30a754a82 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -29,13 +29,13 @@ valueFixity = P.ValueFixityDeclaration ann1 (P.Fixity P.Infix 0) - (P.Qualified P.ByNullSourcePos (Left (P.Ident ""))) + (P.mkQualified_ P.ByNullSourcePos (Left (P.Ident ""))) (P.OpName "<$>") typeFixity = P.TypeFixityDeclaration ann1 (P.Fixity P.Infix 0) - (P.Qualified P.ByNullSourcePos (P.ProperName "")) + (P.mkQualified_ P.ByNullSourcePos (P.ProperName "")) (P.OpName "~>") foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.srcREmpty foreign2 = P.ExternDataDeclaration ann1 (P.ProperName "Foreign2") P.kindType @@ -106,9 +106,9 @@ getLocation s = do , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS , ideTypeClass "SFClass" P.kindType [] `annLoc` classSS - , ideValueOp "<$>" (P.Qualified P.ByNullSourcePos (Left "")) 0 Nothing Nothing + , ideValueOp "<$>" (P.mkQualified_ P.ByNullSourcePos (Left "")) 0 Nothing Nothing `annLoc` valueOpSS - , ideTypeOp "~>" (P.Qualified P.ByNullSourcePos "") 0 Nothing Nothing + , ideTypeOp "~>" (P.mkQualified_ P.ByNullSourcePos "") 0 Nothing Nothing `annLoc` typeOpSS ]) ] diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 5ece522c34..33fcaf22ad 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -11,15 +11,15 @@ import Data.Map qualified as Map valueOperator :: Maybe P.SourceType -> IdeDeclarationAnn valueOperator = - ideValueOp "<$>" (P.Qualified (P.ByModuleName (mn "Test")) (Left "function")) 2 Nothing + ideValueOp "<$>" (P.mkQualified_ (P.ByModuleName (mn "Test")) (Left "function")) 2 Nothing ctorOperator :: Maybe P.SourceType -> IdeDeclarationAnn ctorOperator = - ideValueOp ":" (P.Qualified (P.ByModuleName (mn "Test")) (Right "Cons")) 2 Nothing + ideValueOp ":" (P.mkQualified_ (P.ByModuleName (mn "Test")) (Right "Cons")) 2 Nothing typeOperator :: Maybe P.SourceType -> IdeDeclarationAnn typeOperator = - ideTypeOp ":" (P.Qualified (P.ByModuleName (mn "Test")) "List") 2 Nothing + ideTypeOp ":" (P.mkQualified_ (P.ByModuleName (mn "Test")) "List") 2 Nothing testModule :: (P.ModuleName, [IdeDeclarationAnn]) testModule = @@ -53,7 +53,7 @@ ef = P.ExternsFile --, efDeclarations = [ P.EDInstance -- { edInstanceClassName = - (P.Qualified (P.ByModuleName (mn "ClassModule")) (P.ProperName "MyClass")) + (P.mkQualified_ (P.ByModuleName (mn "ClassModule")) (P.ProperName "MyClass")) -- , edInstanceName = (P.Ident "myClassInstance") -- . edInstanceForAll = diff --git a/tests/TestAst.hs b/tests/TestAst.hs index 1ee48ed180..da7d24fecf 100644 --- a/tests/TestAst.hs +++ b/tests/TestAst.hs @@ -10,7 +10,7 @@ import Test.Hspec (Spec, describe, it) import Test.QuickCheck (Arbitrary(..), Gen, Property, Testable, counterexample, forAllShrink, subterms, (===)) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), properNameFromString, ProperNameType(..), Qualified(..)) +import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), properNameFromString, ProperNameType(..), Qualified(..), mkQualified_) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (Constraint, ConstraintData, SkolemScope(..), Type(..), TypeVarVisibility(..), WildcardData, annForType, everythingOnTypes, everythingWithContextOnTypes, everywhereOnTypes, everywhereOnTypesM, everywhereOnTypesTopDownM, getAnnForType) @@ -74,7 +74,7 @@ genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where genConstraintData = genericArbitraryUG generatorEnvironment genQualified :: forall b. (Text -> b) -> Gen (Qualified b) - genQualified ctor = Qualified ByNullSourcePos . ctor <$> genText + genQualified ctor = mkQualified_ ByNullSourcePos . ctor <$> genText genSkolemScope :: Gen SkolemScope genSkolemScope = SkolemScope <$> arbitrary diff --git a/tests/TestCoreFn.hs b/tests/TestCoreFn.hs index 588c6817b4..1ebfbdb531 100644 --- a/tests/TestCoreFn.hs +++ b/tests/TestCoreFn.hs @@ -15,7 +15,7 @@ import Language.PureScript.Comments (Comment(..)) import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Meta(..), Module(..), ssAnn) import Language.PureScript.CoreFn.FromJSON (moduleFromJSON) import Language.PureScript.CoreFn.ToJSON (moduleToJSON) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..)) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), ProperName(..), QualifiedBy(..), mkQualified_) import Language.PureScript.PSString (mkString) import Test.Hspec (Spec, context, shouldBe, shouldSatisfy, specify) @@ -136,7 +136,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse Abs" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "abs") - $ Abs ann (Ident "x") (Var ann (Qualified (ByModuleName mn) (Ident "x"))) + $ Abs ann (Ident "x") (Var ann (mkQualified_ (ByModuleName mn) (Ident "x"))) ] parseMod m `shouldSatisfy` isSuccess @@ -144,13 +144,13 @@ spec = context "CoreFnFromJson" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "app") $ App ann - (Abs ann (Ident "x") (Var ann (Qualified ByNullSourcePos (Ident "x")))) + (Abs ann (Ident "x") (Var ann (mkQualified_ ByNullSourcePos (Ident "x")))) (Literal ann (CharLiteral 'c')) ] parseMod m `shouldSatisfy` isSuccess specify "should parse UnusedIdent in Abs" $ do - let i = NonRec ann (Ident "f") (Abs ann UnusedIdent (Var ann (Qualified ByNullSourcePos (Ident "x")))) + let i = NonRec ann (Ident "f") (Abs ann UnusedIdent (Var ann (mkQualified_ ByNullSourcePos (Ident "x")))) let r = parseMod $ Module ss [] mn mp [] [] M.empty [] [i] r `shouldSatisfy` isSuccess case r of @@ -161,7 +161,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse Case" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] + Case ann [Var ann (mkQualified_ ByNullSourcePos (Ident "x"))] [ CaseAlternative [ NullBinder ann ] (Right (Literal ann (CharLiteral 'a'))) @@ -172,7 +172,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse Case with guards" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] + Case ann [Var ann (mkQualified_ ByNullSourcePos (Ident "x"))] [ CaseAlternative [ NullBinder ann ] (Left [(Literal ann (BooleanLiteral True), Literal ann (CharLiteral 'a'))]) @@ -184,7 +184,7 @@ spec = context "CoreFnFromJson" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ Let ann - [ Rec [((ann, Ident "a"), Var ann (Qualified ByNullSourcePos (Ident "x")))] ] + [ Rec [((ann, Ident "a"), Var ann (mkQualified_ ByNullSourcePos (Ident "x")))] ] (Literal ann (BooleanLiteral True)) ] parseMod m `shouldSatisfy` isSuccess @@ -222,7 +222,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse LiteralBinder" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] + Case ann [Var ann (mkQualified_ ByNullSourcePos (Ident "x"))] [ CaseAlternative [ LiteralBinder ann (BooleanLiteral True) ] (Right (Literal ann (CharLiteral 'a'))) @@ -233,12 +233,12 @@ spec = context "CoreFnFromJson" $ do specify "should parse VarBinder" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] + Case ann [Var ann (mkQualified_ ByNullSourcePos (Ident "x"))] [ CaseAlternative [ ConstructorBinder ann - (Qualified (ByModuleName (ModuleName "Data.Either")) (ProperName "Either")) - (Qualified ByNullSourcePos (ProperName "Left")) + (mkQualified_ (ByModuleName (ModuleName "Data.Either")) (ProperName "Either")) + (mkQualified_ ByNullSourcePos (ProperName "Left")) [VarBinder ann (Ident "z")] ] (Right (Literal ann (CharLiteral 'a'))) @@ -249,7 +249,7 @@ spec = context "CoreFnFromJson" $ do specify "should parse NamedBinder" $ do let m = Module ss [] mn mp [] [] M.empty [] [ NonRec ann (Ident "case") $ - Case ann [Var ann (Qualified ByNullSourcePos (Ident "x"))] + Case ann [Var ann (mkQualified_ ByNullSourcePos (Ident "x"))] [ CaseAlternative [ NamedBinder ann (Ident "w") (NamedBinder ann (Ident "w'") (VarBinder ann (Ident "w''"))) ] (Right (Literal ann (CharLiteral 'a'))) diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index 02ad1f4f84..d2b805ff0e 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -2,7 +2,6 @@ module TestDocs where import Prelude -import GHC.Stack (HasCallStack) import Data.Bifunctor (first) import Data.List (findIndex) import Data.Foldable (find, forM_) @@ -126,7 +125,7 @@ data TagsAssertion -- | Assert that a particular declaration is not tagged | ShouldNotBeTagged Text -displayAssertion :: HasCallStack => DocsAssertion -> Text +displayAssertion :: DocsAssertion -> Text displayAssertion = \case ShouldBeDocumented mn decl children -> showQual mn decl <> " should be documented" <> @@ -978,7 +977,7 @@ testTagsCases = ]) ] -showQual :: HasCallStack => P.ModuleName -> Text -> Text +showQual :: P.ModuleName -> Text -> Text showQual mn decl = P.runModuleName mn <> "." <> decl diff --git a/tests/TestHierarchy.hs b/tests/TestHierarchy.hs index 2ba3e82946..1529ac0f1b 100644 --- a/tests/TestHierarchy.hs +++ b/tests/TestHierarchy.hs @@ -51,7 +51,7 @@ spec = describe "hierarchy" $ do (P.internalModuleSourceSpan "", []) (P.ProperName "B") [] - [P.srcConstraint (P.Qualified P.ByNullSourcePos $ P.ProperName "A") [] [] Nothing] + [P.srcConstraint (P.mkQualified_ P.ByNullSourcePos $ P.ProperName "A") [] [] Nothing] [] [] ] From 89b04a94fb6c31bfcb55a95bfd9821202983d718 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Sun, 11 May 2025 17:04:58 +0000 Subject: [PATCH 06/19] Hash map for typeclass dictionaries --- purescript.cabal | 4 ++-- src/Language/PureScript/AST/Declarations.hs | 4 ++-- src/Language/PureScript/AST/SourcePos.hs | 3 ++- src/Language/PureScript/AST/Traversals.hs | 4 ++-- src/Language/PureScript/Environment.hs | 5 ++-- src/Language/PureScript/Externs.hs | 16 +++++++------ src/Language/PureScript/Names.hs | 17 +++++++++---- src/Language/PureScript/TypeChecker.hs | 13 +++++----- .../PureScript/TypeChecker/Deriving.hs | 5 ++-- .../PureScript/TypeChecker/Entailment.hs | 17 ++++++------- src/Language/PureScript/TypeChecker/Monad.hs | 24 ++++++++++--------- .../PureScript/TypeChecker/TypeSearch.hs | 3 ++- 12 files changed, 66 insertions(+), 49 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index e5823202a6..fa732780fc 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -168,8 +168,8 @@ common defaults cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, containers >=0.6.5.1 && <0.7, - -- unordered-containers, - -- hashable, + unordered-containers, + hashable, cryptonite ==0.30.*, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 7184cbb812..60f9efc0a1 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -14,7 +14,6 @@ import Control.DeepSeq (NFData) import Data.Functor.Identity (Identity(..)) import Data.Aeson.TH (Options(..), SumEncoding(..), defaultOptions, deriveJSON) -import Data.Map qualified as M import Data.Text (Text) import Data.List.NonEmpty qualified as NEL import GHC.Generics (Generic) @@ -33,6 +32,7 @@ import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Comments (Comment) import Language.PureScript.Environment (DataDeclType, Environment, FunctionalDependency, NameKind) import Language.PureScript.Constants.Prim qualified as C +import Data.HashMap.Strict qualified as HM -- | A map of locally-bound names in scope. type Context = [(Ident, SourceType)] @@ -740,7 +740,7 @@ data Expr -- instance type, and the type class dictionaries in scope. -- | TypeClassDictionary SourceConstraint - (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) + (HM.HashMap QualifiedBy (HM.HashMap (Qualified (ProperName 'ClassName)) (HM.HashMap (Qualified Ident) (NEL.NonEmpty NamedDict)))) [ErrorMessageHint] -- | -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs index 262d44b6a1..fcb33f45c6 100644 --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -15,6 +15,7 @@ import Language.PureScript.Comments (Comment) import Data.Aeson qualified as A import Data.Text qualified as T import System.FilePath (makeRelative) +import Data.Hashable (Hashable) -- | Source annotation - position information and comments. type SourceAnn = (SourceSpan, [Comment]) @@ -25,7 +26,7 @@ data SourcePos = SourcePos -- ^ Line number , sourcePosColumn :: Int -- ^ Column number - } deriving (Show, Eq, Ord, Generic, NFData, Serialise) + } deriving (Show, Eq, Ord, Generic, NFData, Serialise, Hashable) displaySourcePos :: SourcePos -> Text displaySourcePos sp = diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index abbe6e5a15..fcf7d06bd7 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -14,7 +14,7 @@ import Data.Functor.Identity (runIdentity) import Data.List (mapAccumL) import Data.Maybe (mapMaybe) import Data.List.NonEmpty qualified as NEL -import Data.Map qualified as M +import Data.HashMap.Strict qualified as HM import Data.Set qualified as S import Language.PureScript.AST.Binders (Binder(..), binderNames) @@ -718,4 +718,4 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f' g other = other updateDict fn dict = dict { tcdInstanceTypes = fn (tcdInstanceTypes dict) } updateScope = fmap . fmap . fmap . fmap $ updateDict $ fmap f - updateCtx = M.alter updateScope ByNullSourcePos + updateCtx = HM.alter updateScope ByNullSourcePos diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 0c087e9cf1..5d3a9722ab 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -12,6 +12,7 @@ import Data.Foldable (find, fold) import Data.Functor ((<&>)) import Data.IntMap qualified as IM import Data.IntSet qualified as IS +import Data.HashMap.Strict qualified as HM import Data.Map qualified as M import Data.Set qualified as S import Data.Maybe (fromMaybe, mapMaybe) @@ -39,7 +40,7 @@ data Environment = Environment -- constructor name, argument types and return type. , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) -- ^ Type synonyms currently in scope - , typeClassDictionaries :: M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) + , typeClassDictionaries :: HM.HashMap QualifiedBy (HM.HashMap (Qualified (ProperName 'ClassName)) (HM.HashMap (Qualified Ident) (NEL.NonEmpty NamedDict))) -- ^ Available type class dictionaries. When looking up 'Nothing' in the -- outer map, this returns the map of type class dictionaries in local -- scope (ie dictionaries brought in by a constrained type). @@ -101,7 +102,7 @@ instance A.ToJSON FunctionalDependency where -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment -initEnvironment = Environment M.empty allPrimTypes M.empty M.empty M.empty allPrimClasses +initEnvironment = Environment M.empty allPrimTypes M.empty M.empty HM.empty allPrimClasses -- | A constructor for TypeClassData that computes which type class arguments are fully determined -- and argument covering sets. diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a949aacae6..fa34b35a5f 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -40,6 +40,8 @@ import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionary import Language.PureScript.Types (SourceConstraint, SourceType, srcInstanceType) import Paths_purescript as Paths +import Data.HashMap.Strict qualified as HM +import Data.Hashable (Hashable) -- | The data which will be serialized to an externs file data ExternsFile = ExternsFile @@ -183,15 +185,15 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) = env { typeClassDictionaries = - updateMap - (updateMap (M.insertWith (<>) (qual ident) (pure dict)) className) + updateHMap + (updateHMap (HM.insertWith (<>) (qual ident) (pure dict)) className) (ByModuleName efModuleName) (typeClassDictionaries env) } where dict :: NamedDict dict = TypeClassDictionaryInScope ch idx (qual ident) [] className vars kinds tys cs instTy - updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a - updateMap f = M.alter (Just . f . fold) + updateHMap :: (Hashable k, Monoid a) => (a -> a) -> k -> HM.HashMap k a -> HM.HashMap k a + updateHMap f = HM.alter (Just . f . fold) instTy :: Maybe SourceType instTy = case ns of @@ -264,9 +266,9 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF ] toExternsDeclaration (TypeInstanceRef ss' ident ns) = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss' - | m1 <- maybeToList (M.lookup (ByModuleName mn) (typeClassDictionaries env)) - , m2 <- M.elems m1 - , nel <- maybeToList (M.lookup (Qualified (ByModuleName mn) ident) m2) + | m1 <- maybeToList (HM.lookup (ByModuleName mn) (typeClassDictionaries env)) + , m2 <- HM.elems m1 + , nel <- maybeToList (HM.lookup (Qualified (ByModuleName mn) ident) m2) , TypeClassDictionaryInScope{..} <- NEL.toList nel ] toExternsDeclaration _ = [] diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 094ae5773d..90b69bdce1 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveAnyClass #-} -- | -- Data types for names @@ -20,6 +22,7 @@ import Data.Aeson.TH (deriveJSON) import Data.Text (Text) import Data.Text qualified as T import Data.Int (Int64) +import Data.Hashable (Hashable) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) @@ -32,7 +35,7 @@ data Name | DctorName (ProperName 'ConstructorName) | TyClassName (ProperName 'ClassName) | ModName ModuleName - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, Hashable) instance NFData Name instance Serialise Name @@ -71,7 +74,7 @@ getClassName _ = Nothing data InternalIdentData -- Used by CoreFn.Laziness = RuntimeLazyFactory | Lazy !Text - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Hashable) instance NFData InternalIdentData instance Serialise InternalIdentData @@ -96,7 +99,7 @@ data Ident -- A generated name used only for internal transformations -- | InternalIdent !InternalIdentData - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Hashable) instance NFData Ident instance Serialise Ident @@ -129,6 +132,7 @@ isPlainIdent _ = False -- newtype OpName (a :: OpNameType) = OpName { runOpName :: Text } deriving (Show, Eq, Ord, Generic) + deriving newtype Hashable instance NFData (OpName a) instance Serialise (OpName a) @@ -158,6 +162,8 @@ coerceOpName = OpName . runOpName -- newtype ProperName (a :: ProperNameType) = ProperName { runProperName :: Text } deriving (Show, Eq, Ord, Generic) + deriving newtype (Hashable) + instance NFData (ProperName a) instance Serialise (ProperName a) @@ -191,6 +197,7 @@ coerceProperName = ProperName . runProperName newtype ModuleName = ModuleName Text deriving (Show, Eq, Ord, Generic) deriving newtype Serialise + deriving newtype (Hashable) instance NFData ModuleName @@ -206,7 +213,7 @@ isBuiltinModuleName (ModuleName mn) = mn == "Prim" || "Prim." `T.isPrefixOf` mn data QualifiedBy = BySourcePos SourcePos | ByModuleName ModuleName - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Hashable) pattern ByNullSourcePos :: QualifiedBy pattern ByNullSourcePos = BySourcePos (SourcePos 0 0) @@ -230,7 +237,7 @@ toMaybeModuleName (BySourcePos _) = Nothing -- A qualified name, i.e. a name with an optional module name -- data Qualified a = Qualified QualifiedBy a - deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Hashable) instance NFData a => NFData (Qualified a) instance Serialise a => Serialise (Qualified a) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index fd4e7c7982..8bf2094ccc 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -46,6 +46,7 @@ import Language.PureScript.TypeChecker.Types as T import Language.PureScript.TypeChecker.Unify (varIfUnknown) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, overConstraintArgs, srcInstanceType, unapplyTypes) +import Data.HashMap.Strict qualified as HM addDataType :: ModuleName @@ -175,11 +176,11 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do addTypeClassDictionaries :: QualifiedBy - -> M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) + -> HM.HashMap (Qualified (ProperName 'ClassName)) (HM.HashMap (Qualified Ident) (NEL.NonEmpty NamedDict)) -> TypeCheckM () addTypeClassDictionaries mn entries = modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = insertState st } } - where insertState st = M.insertWith (M.unionWith (M.unionWith (<>))) mn entries (typeClassDictionaries . checkEnv $ st) + where insertState st = HM.insertWith (HM.unionWith (HM.unionWith (<>))) mn entries (typeClassDictionaries . checkEnv $ st) checkDuplicateTypeArguments :: [Text] @@ -379,7 +380,7 @@ typeCheckAll moduleName = traverse go let qualifiedDictName = Qualified (ByModuleName moduleName) dictName flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> guardWith (errorMessage (DuplicateInstance dictName ss)) $ - not (M.member qualifiedDictName dictionaries) + not (HM.member qualifiedDictName dictionaries) case M.lookup className (typeClasses env) of Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do @@ -396,7 +397,7 @@ typeCheckAll moduleName = traverse go let dict = TypeClassDictionaryInScope chainId idx qualifiedDictName [] className vars kinds' tys'' (Just deps'') $ if isPlainIdent dictName then Nothing else Just $ srcInstanceType ss vars className tys'' - addTypeClassDictionaries (ByModuleName moduleName) . M.singleton className $ M.singleton (tcdValue dict) (pure dict) + addTypeClassDictionaries (ByModuleName moduleName) . HM.singleton className $ HM.singleton (tcdValue dict) (pure dict) return d checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [SourceType] -> TypeCheckM () @@ -478,7 +479,7 @@ typeCheckAll moduleName = traverse go -> TypeCheckM () checkOverlappingInstance ss ch dictName vars className typeClass tys' nonOrphanModules = do for_ nonOrphanModules $ \m -> do - dicts <- M.toList <$> lookupTypeClassDictionariesForClass (ByModuleName m) className + dicts <- HM.toList <$> lookupTypeClassDictionariesForClass (ByModuleName m) className for_ dicts $ \(Qualified mn' ident, dictNel) -> do for_ dictNel $ \dict -> do @@ -753,7 +754,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = ] $ \className -> do env <- getEnv let dicts = foldMap (foldMap NEL.toList) $ - M.lookup (ByModuleName mn) (typeClassDictionaries env) >>= M.lookup className + HM.lookup (ByModuleName mn) (typeClassDictionaries env) >>= HM.lookup className when (any isDictOfTypeRef dicts) $ tell . errorMessage' ss' $ HiddenConstructors dr className | otherwise = do diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 502a3dc05d..377fd658b4 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -31,6 +31,7 @@ import Language.PureScript.TypeChecker.Monad (getEnv, getTypeClassDictionaries, import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.TypeClassDictionaries (TypeClassDictionaryInScope(..)) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, SourceType, Type(..), completeBinderList, eqType, everythingOnTypes, replaceAllTypeVars, srcTypeVar, usedTypeVariables) +import Data.HashMap.Strict qualified as HM -- | Extract the name of the newtype appearing in the last type argument of -- a derived newtype instance. @@ -173,8 +174,8 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs lookIn mn' = elem nt . (toList . extractNewtypeName mn' . tcdInstanceTypes - <=< foldMap toList . M.elems - <=< toList . (M.lookup su <=< M.lookup (ByModuleName mn'))) + <=< foldMap toList . HM.elems + <=< toList . (HM.lookup su <=< HM.lookup (ByModuleName mn'))) $ dicts in lookIn suModule || lookIn newtypeModule diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7895e541b1..d9d7fd473a 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -27,6 +27,7 @@ import Data.Functor (($>), (<&>)) import Data.List (delete, findIndices, minimumBy, nubBy, sortOn, tails) import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Data.Map qualified as M +import Data.HashMap.Strict qualified as HM import Data.Set qualified as S import Data.Traversable (for) import Data.Text (Text, stripPrefix, stripSuffix) @@ -93,12 +94,12 @@ namedInstanceIdentifier _ = Nothing type TypeClassDict = TypeClassDictionaryInScope Evidence -- | The 'InstanceContext' tracks those constraints which can be satisfied. -type InstanceContext = M.Map QualifiedBy - (M.Map (Qualified (ProperName 'ClassName)) - (M.Map (Qualified Ident) (NonEmpty NamedDict))) +type InstanceContext = HM.HashMap QualifiedBy + (HM.HashMap (Qualified (ProperName 'ClassName)) + (HM.HashMap (Qualified Ident) (NonEmpty NamedDict))) findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> QualifiedBy -> [TypeClassDict] -findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.elems . (M.lookup cn <=< flip M.lookup ctx) +findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap HM.elems . (HM.lookup cn <=< flip HM.lookup ctx) -- | A type substitution which makes an instance head match a list of types. -- @@ -107,7 +108,7 @@ findDicts ctx cn = fmap (fmap NamedInstance) . foldMap NEL.toList . foldMap M.el type Matching a = M.Map Text a combineContexts :: InstanceContext -> InstanceContext -> InstanceContext -combineContexts = M.unionWith (M.unionWith (M.unionWith (<>))) +combineContexts = HM.unionWith (HM.unionWith (HM.unionWith (<>))) -- | Replace type class dictionary placeholders with inferred type class dictionaries replaceTypeClassDictionaries @@ -115,7 +116,7 @@ replaceTypeClassDictionaries Bool -> Expr -> TypeCheckM (Expr, [(Ident, InstanceContext, SourceConstraint)]) -replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT M.empty $ do +replaceTypeClassDictionaries shouldGeneralize expr = flip evalStateT HM.empty $ do -- Loop, deferring any unsolved constraints, until there are no more -- constraints which can be solved, then make a generalization pass. let loop e = do @@ -883,8 +884,8 @@ newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = return (TypeClassDictionaryInScope Nothing 0 name path className [] instanceKinds instanceTy Nothing Nothing : supDicts) mkContext :: [NamedDict] -> InstanceContext -mkContext = foldr combineContexts M.empty . map fromDict where - fromDict d = M.singleton ByNullSourcePos (M.singleton (tcdClassName d) (M.singleton (tcdValue d) (pure d))) +mkContext = foldr combineContexts HM.empty . map fromDict where + fromDict d = HM.singleton ByNullSourcePos (HM.singleton (tcdClassName d) (HM.singleton (tcdValue d) (pure d))) -- | Check all pairs of values in a list match a predicate pairwiseAll :: Monoid m => (a -> a -> m) -> [a] -> m diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 831c629d9b..5f0959a049 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -35,6 +35,7 @@ import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Logger (Logger, runLogger') import Control.Monad.Supply.Class qualified as Supply +import Data.HashMap.Strict qualified as HM newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors Logger)) a } deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) @@ -218,34 +219,34 @@ withTypeClassDictionaries entries action = do orig <- get let mentries = - M.fromListWith (M.unionWith (M.unionWith (<>))) - [ (qb, M.singleton className (M.singleton tcdValue (pure entry))) + HM.fromListWith (HM.unionWith (HM.unionWith (<>))) + [ (qb, HM.singleton className (HM.singleton tcdValue (pure entry))) | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className } <- entries ] - modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = M.unionWith (M.unionWith (M.unionWith (<>))) (typeClassDictionaries . checkEnv $ st) mentries } } + modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = HM.unionWith (HM.unionWith (HM.unionWith (<>))) (typeClassDictionaries . checkEnv $ st) mentries } } a <- action modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } } return a -- | Get the currently available map of type class dictionaries getTypeClassDictionaries - :: TypeCheckM (M.Map QualifiedBy (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)))) + :: TypeCheckM (HM.HashMap QualifiedBy (HM.HashMap (Qualified (ProperName 'ClassName)) (HM.HashMap (Qualified Ident) (NEL.NonEmpty NamedDict)))) getTypeClassDictionaries = gets $ typeClassDictionaries . checkEnv -- | Lookup type class dictionaries in a module. lookupTypeClassDictionaries :: QualifiedBy - -> TypeCheckM (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict))) -lookupTypeClassDictionaries mn = gets $ fromMaybe M.empty . M.lookup mn . typeClassDictionaries . checkEnv + -> TypeCheckM (HM.HashMap (Qualified (ProperName 'ClassName)) (HM.HashMap (Qualified Ident) (NEL.NonEmpty NamedDict))) +lookupTypeClassDictionaries mn = gets $ fromMaybe HM.empty . HM.lookup mn . typeClassDictionaries . checkEnv -- | Lookup type class dictionaries in a module. lookupTypeClassDictionariesForClass :: QualifiedBy -> Qualified (ProperName 'ClassName) - -> TypeCheckM (M.Map (Qualified Ident) (NEL.NonEmpty NamedDict)) -lookupTypeClassDictionariesForClass mn cn = fromMaybe M.empty . M.lookup cn <$> lookupTypeClassDictionaries mn + -> TypeCheckM (HM.HashMap (Qualified Ident) (NEL.NonEmpty NamedDict)) +lookupTypeClassDictionariesForClass mn cn = fromMaybe HM.empty . HM.lookup cn <$> lookupTypeClassDictionaries mn -- | Temporarily bind a collection of names to local variables bindLocalVariables @@ -450,10 +451,11 @@ debugTypeSynonyms = fmap go . M.toList . typeSynonyms debugTypeClassDictionaries :: Environment -> [String] debugTypeClassDictionaries = go . typeClassDictionaries where + -- TODO: order? go tcds = do - (mbModuleName, classes) <- M.toList tcds - (className, instances) <- M.toList classes - (ident, dicts) <- M.toList instances + (mbModuleName, classes) <- HM.toList tcds + (className, instances) <- HM.toList classes + (ident, dicts) <- HM.toList instances let moduleName = maybe "" (\m -> "[" <> runModuleName m <> "] ") (toMaybeModuleName mbModuleName) className' = showQualified runProperName className diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index e8812a5439..60b19b62ec 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -6,6 +6,7 @@ import Protolude import Control.Monad.Writer (WriterT, runWriterT) import Data.Map qualified as Map +import Data.HashMap.Strict qualified as HM import Language.PureScript.TypeChecker.Entailment qualified as Entailment import Language.PureScript.TypeChecker.Monad qualified as TC @@ -75,7 +76,7 @@ checkSubsume unsolved env st userT envT = checkInEnvironment env st $ do -- Now check that any unsolved constraints have not become impossible (traverse_ . traverse_) (\(_, context, constraint) -> do let constraint' = P.mapConstraintArgs (map (P.substituteType subst)) constraint - flip evalStateT Map.empty . evalWriterT $ + flip evalStateT HM.empty . evalWriterT $ Entailment.entails (Entailment.SolverOptions { solverShouldGeneralize = True From 261465d5535dc8a62c83357e20db83e840727e6e Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Tue, 13 May 2025 21:55:02 +0000 Subject: [PATCH 07/19] Hash Type a and use a hash set in unification cache --- src/Language/PureScript/Label.hs | 2 + src/Language/PureScript/PSString.hs | 2 + src/Language/PureScript/TypeChecker/Monad.hs | 5 ++- src/Language/PureScript/TypeChecker/Unify.hs | 8 ++-- src/Language/PureScript/Types.hs | 40 ++++++++++++++++++++ 5 files changed, 51 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Label.hs b/src/Language/PureScript/Label.hs index a5d080a76c..392bd302f3 100644 --- a/src/Language/PureScript/Label.hs +++ b/src/Language/PureScript/Label.hs @@ -7,6 +7,7 @@ import Control.DeepSeq (NFData) import Data.Monoid () import Data.String (IsString(..)) import Data.Aeson qualified as A +import Data.Hashable (Hashable) import Language.PureScript.PSString (PSString) @@ -16,6 +17,7 @@ import Language.PureScript.PSString (PSString) -- newtype Label = Label { runLabel :: PSString } deriving (Show, Eq, Ord, IsString, Semigroup, Monoid, A.ToJSON, A.FromJSON, Generic) + deriving newtype Hashable instance NFData Label instance Serialise Label diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 2ceb481181..dcaac58d1d 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -33,6 +33,7 @@ import Numeric (showHex) import System.IO.Unsafe (unsafePerformIO) import Data.Aeson qualified as A import Data.Aeson.Types qualified as A +import Data.Hashable (Hashable) -- | -- Strings in PureScript are sequences of UTF-16 code units, which do not @@ -50,6 +51,7 @@ import Data.Aeson.Types qualified as A -- newtype PSString = PSString { toUTF16CodeUnits :: [Word16] } deriving (Eq, Ord, Semigroup, Monoid, Generic) + deriving newtype Hashable instance NFData PSString instance Serialise PSString diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 5f0959a049..6c498b5845 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -36,6 +36,7 @@ import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Logger (Logger, runLogger') import Control.Monad.Supply.Class qualified as Supply import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors Logger)) a } deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) @@ -133,12 +134,12 @@ data CheckState = CheckState , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName)) -- ^ Newtype constructors imports required to solve Coercible constraints. -- We have to keep track of them so that we don't emit unused import warnings. - , unificationCache :: S.Set (SourceType, SourceType) + , unificationCache :: HS.HashSet (SourceType, SourceType) } -- | Create an empty @CheckState@ emptyCheckState :: Environment -> CheckState -emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty mempty +emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty HS.empty -- | Unification variables type Unknown = Int diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 28a237dc6a..9f3bef1b01 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -16,7 +16,7 @@ module Language.PureScript.TypeChecker.Unify import Prelude -import Control.Monad (forM_, void, when) +import Control.Monad (forM_, void, unless) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..), gets, modify, state) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -33,7 +33,7 @@ import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, un import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown) -import Data.Set qualified as S +import Data.HashSet qualified as HS -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible. freshType :: TypeCheckM SourceType @@ -114,8 +114,8 @@ unifyTypes t1 t2 = do where unifyTypes'' t1' t2'= do cache <- gets unificationCache - when (S.notMember (t1', t2') cache) $ do - modify $ \st -> st { unificationCache = S.insert (t1', t2') cache } + unless (HS.member (t1', t2') cache) $ do + modify $ \st -> st { unificationCache = HS.insert (t1', t2') cache } unifyTypes' t1' t2' unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index ef00e21a07..b659bd21ae 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -28,6 +28,7 @@ import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName) import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) +import Data.Hashable (Hashable (hashWithSalt)) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn @@ -40,6 +41,7 @@ newtype SkolemScope = SkolemScope { runSkolemScope :: Int } instance NFData SkolemScope instance Serialise SkolemScope +instance Hashable SkolemScope -- | -- Describes how a TypeWildcard should be presented to the user during @@ -52,6 +54,7 @@ data WildcardData = HoleWildcard Text | UnnamedWildcard | IgnoredWildcard instance NFData WildcardData instance Serialise WildcardData +instance Hashable WildcardData data TypeVarVisibility = TypeVarVisible @@ -60,6 +63,7 @@ data TypeVarVisibility instance NFData TypeVarVisibility instance Serialise TypeVarVisibility +instance Hashable TypeVarVisibility typeVarVisibilityPrefix :: TypeVarVisibility -> Text typeVarVisibilityPrefix = \case @@ -115,6 +119,9 @@ data Type a instance NFData a => NFData (Type a) instance Serialise a => Serialise (Type a) +instance Hashable (Type a) where + hashWithSalt = hashType + srcTUnknown :: Int -> SourceType srcTUnknown = TUnknown NullSourceAnn @@ -177,6 +184,7 @@ data ConstraintData instance NFData ConstraintData instance Serialise ConstraintData +instance Hashable ConstraintData -- | A typeclass constraint data Constraint a = Constraint @@ -815,6 +823,33 @@ eqMaybeType (Just a) (Just b) = eqType a b eqMaybeType Nothing Nothing = True eqMaybeType _ _ = False +infixl 0 `hashType` +hashType :: Int -> Type a -> Int +hashType s = \case + (TUnknown _ a) -> hashWithSalt s a + (TypeVar _ a) -> hashWithSalt s a + (TypeLevelString _ a) -> hashWithSalt s a + (TypeLevelInt _ a) -> hashWithSalt s a + (TypeWildcard _ a) -> hashWithSalt s a + (TypeConstructor _ a) -> hashWithSalt s a + (TypeOp _ a) -> hashWithSalt s a + (TypeApp _ a b) -> s `hashType` a `hashType` b + (KindApp _ a b) -> s `hashType` a `hashType` b + (ForAll _ _ a b c d) -> + s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d + (ConstrainedType _ a b) -> s `hashWithSalt` a `hashType` b + (Skolem _ a b c d) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d + (REmpty _) -> hashWithSalt s ("REmpty" :: Text) + (RCons _ a b c) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c + (KindedType _ a b) -> s `hashWithSalt` a `hashWithSalt` b + (BinaryNoParensType _ a b c) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c + (ParensInType _ a) -> hashWithSalt s a + +infixl 0 `hashTypeMaybe` +hashTypeMaybe :: Int -> Maybe (Type a) -> Int +hashTypeMaybe s Nothing = s `hashWithSalt` (0 :: Int) +hashTypeMaybe s (Just a) = s `hashType` a + compareType :: Type a -> Type b -> Ordering compareType (TUnknown _ a) (TUnknown _ a') = compare a a' compareType (TypeVar _ a) (TypeVar _ a') = compare a a' @@ -855,6 +890,7 @@ compareType typ typ' = orderOf BinaryNoParensType{} = 15 orderOf ParensInType{} = 16 + compareMaybeType :: Maybe (Type a) -> Maybe (Type b) -> Ordering compareMaybeType (Just a) (Just b) = compareType a b compareMaybeType Nothing Nothing = EQ @@ -867,8 +903,12 @@ instance Eq (Constraint a) where instance Ord (Constraint a) where compare = compareConstraint +instance Hashable (Constraint a) where + hashWithSalt s (Constraint _ a b c d) = s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d + eqConstraint :: Constraint a -> Constraint b -> Bool eqConstraint (Constraint _ a b c d) (Constraint _ a' b' c' d') = a == a' && and (zipWith eqType b b') && and (zipWith eqType c c') && d == d' compareConstraint :: Constraint a -> Constraint b -> Ordering compareConstraint (Constraint _ a b c d) (Constraint _ a' b' c' d') = compare a a' <> fold (zipWith compareType b b') <> fold (zipWith compareType c c') <> compare d d' + From ba88b9d87ddcba994eaef011af2e26679de5203c Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Wed, 14 May 2025 10:35:31 +0000 Subject: [PATCH 08/19] WIP Add hashable --- src/Language/PureScript/AST/Operators.hs | 2 ++ src/Language/PureScript/CST/Convert.hs | 3 +- src/Language/PureScript/CST/Types.hs | 3 +- src/Language/PureScript/Constants/TH.hs | 10 +++--- src/Language/PureScript/CoreFn/FromJSON.hs | 3 +- src/Language/PureScript/Externs.hs | 2 +- src/Language/PureScript/Ide/Types.hs | 18 +++++------ src/Language/PureScript/Names.hs | 32 ++++++++++++------- src/Language/PureScript/Sugar/Names.hs | 3 +- .../PureScript/Sugar/Names/Imports.hs | 3 +- src/Language/PureScript/TypeChecker.hs | 3 +- tests/TestAst.hs | 2 +- 12 files changed, 51 insertions(+), 33 deletions(-) diff --git a/src/Language/PureScript/AST/Operators.hs b/src/Language/PureScript/AST/Operators.hs index eb217a2444..7ec8b0ea9a 100644 --- a/src/Language/PureScript/AST/Operators.hs +++ b/src/Language/PureScript/AST/Operators.hs @@ -12,6 +12,7 @@ import Data.Aeson ((.=)) import Data.Aeson qualified as A import Language.PureScript.Crash (internalError) +import Data.Hashable (Hashable) -- | -- A precedence level for an infix operator @@ -26,6 +27,7 @@ data Associativity = Infixl | Infixr | Infix instance NFData Associativity instance Serialise Associativity +instance Hashable Associativity showAssoc :: Associativity -> String showAssoc Infixl = "infixl" diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 583bce04ca..8ab21a53dc 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -37,6 +37,7 @@ import Language.PureScript.Types qualified as T import Language.PureScript.CST.Positions import Language.PureScript.CST.Print (printToken) import Language.PureScript.CST.Types +import Data.Hashable (Hashable) comment :: Comment a -> Maybe C.Comment comment = \case @@ -89,7 +90,7 @@ moduleName = \case go [] = Nothing go ns = Just $ N.moduleNameFromString $ Text.intercalate "." ns -qualified :: QualifiedName a -> N.Qualified a +qualified :: Hashable a=> QualifiedName a -> N.Qualified a qualified q = N.mkQualified_ qb (qualName q) where qb = maybe N.ByNullSourcePos N.ByModuleName $ qualModule q diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs index ba90f7e95b..821d1d8c1a 100644 --- a/src/Language/PureScript/CST/Types.hs +++ b/src/Language/PureScript/CST/Types.hs @@ -18,6 +18,7 @@ import GHC.Generics (Generic) import Language.PureScript.Names qualified as N import Language.PureScript.Roles qualified as R import Language.PureScript.PSString (PSString) +import Data.Hashable (Hashable) data SourcePos = SourcePos { srcLine :: {-# UNPACK #-} !Int @@ -90,7 +91,7 @@ data SourceToken = SourceToken data Ident = Ident { getIdent :: Text - } deriving (Show, Eq, Ord, Generic) + } deriving (Show, Eq, Ord, Generic, Hashable) data Name a = Name { nameTok :: SourceToken diff --git a/src/Language/PureScript/Constants/TH.hs b/src/Language/PureScript/Constants/TH.hs index 7430a8079e..c568d0ce87 100644 --- a/src/Language/PureScript/Constants/TH.hs +++ b/src/Language/PureScript/Constants/TH.hs @@ -75,7 +75,8 @@ import Control.Monad.Trans.Writer (Writer, execWriter) import Control.Monad.Writer.Class (tell) import Data.String (String, fromString) import Language.Haskell.TH (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL, nameBase, Lit (IntegerL)) -import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString) +import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, properNameFromString) +import Data.Text qualified as T -- | Generate pattern synonyms corresponding to the provided PureScript -- declarations. @@ -191,12 +192,12 @@ mkPrefixedName tag prefix = mkName . (tag <>) . camelAppend prefix -- 'TypeName -> M_Data_Foo -> "Function" -> "Foo" -> -- pattern FunctionFoo :: Qualified (ProperName 'TypeName) -- pattern FunctionFoo = Qualified (ByModuleName M_Data_Foo) (ProperName "Foo") - mkPnPat :: Q Type -> VarToDec mkPnPat pnType mn prefix str = do let modNameStr = nameBase mn -- Compute the hash - let hashValue = toInteger (hash (ByModuleName (moduleNameFromString (fromString modNameStr)))) + let q = ByModuleName (moduleNameFromString (fromString modNameStr)) + let hashValue = toInteger (hashWithSalt 1 q `hashWithSalt` properNameFromString (T.pack str)) typedPatSyn (mkName $ cap prefix <> str) [t| Qualified (ProperName $pnType) |] [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str)) $(litP $ IntegerL hashValue) |] @@ -209,7 +210,8 @@ mkIdentDec :: VarToDec mkIdentDec mn prefix str = do let modNameStr = nameBase mn -- Compute the hash - let hashValue = toInteger (hash (ByModuleName (moduleNameFromString (fromString modNameStr)))) + let q = ByModuleName (moduleNameFromString (fromString modNameStr)) + let hashValue = toInteger (hashWithSalt 1 q `hashWithSalt` Ident (T.pack str)) typedPatSyn (mkPrefixedName "I_" prefix str) [t| Qualified Ident |] diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 783dad5da4..ae057d6b15 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -27,6 +27,7 @@ import Language.PureScript.Names (Ident(..), ModuleName(..), properNameFromStrin import Language.PureScript.PSString (PSString) import Text.ParserCombinators.ReadP (readP_to_S) +import Data.Hashable (Hashable) parseVersion' :: String -> Maybe Version parseVersion' str = @@ -110,7 +111,7 @@ identFromJSON = withText "Ident" $ \case properNameFromJSON :: Value -> Parser (ProperName a) properNameFromJSON = fmap properNameFromString . parseJSON -qualifiedFromJSON :: (Text -> a) -> Value -> Parser (Qualified a) +qualifiedFromJSON :: Hashable a => (Text -> a) -> Value -> Parser (Qualified a) qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj where qualifiedFromObj o = diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 5b0844dcaa..a2a64e14b2 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -200,7 +200,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar CompilerNamed -> Just $ srcInstanceType ss vars className tys UserNamed -> Nothing - qual :: a -> Qualified a + qual :: Hashable a => a -> Qualified a qual = mkQualified_ (ByModuleName efModuleName) -- | Generate an externs file for all declarations in a module. diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 41532a3c51..b9216bbd48 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -31,43 +31,43 @@ data IdeDeclaration | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator | IdeDeclModule P.ModuleName - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic, Hashable) data IdeValue = IdeValue { _ideValueIdent :: P.Ident , _ideValueType :: P.SourceType - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, Hashable) data IdeType = IdeType { _ideTypeName :: P.ProperName 'P.TypeName , _ideTypeKind :: P.SourceType , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.SourceType)] - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, Hashable) data IdeTypeSynonym = IdeTypeSynonym { _ideSynonymName :: P.ProperName 'P.TypeName , _ideSynonymType :: P.SourceType , _ideSynonymKind :: P.SourceType - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, Hashable) data IdeDataConstructor = IdeDataConstructor { _ideDtorName :: P.ProperName 'P.ConstructorName , _ideDtorTypeName :: P.ProperName 'P.TypeName , _ideDtorType :: P.SourceType - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, Hashable) data IdeTypeClass = IdeTypeClass { _ideTCName :: P.ProperName 'P.ClassName , _ideTCKind :: P.SourceType , _ideTCInstances :: [IdeInstance] - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, Hashable) data IdeInstance = IdeInstance { _ideInstanceModule :: P.ModuleName , _ideInstanceName :: P.Ident , _ideInstanceTypes :: [P.SourceType] , _ideInstanceConstraints :: Maybe [P.SourceConstraint] - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, Hashable) data IdeValueOperator = IdeValueOperator { _ideValueOpName :: P.OpName 'P.ValueOpName @@ -75,7 +75,7 @@ data IdeValueOperator = IdeValueOperator , _ideValueOpPrecedence :: P.Precedence , _ideValueOpAssociativity :: P.Associativity , _ideValueOpType :: Maybe P.SourceType - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, Hashable) data IdeTypeOperator = IdeTypeOperator { _ideTypeOpName :: P.OpName 'P.TypeOpName @@ -83,7 +83,7 @@ data IdeTypeOperator = IdeTypeOperator , _ideTypeOpPrecedence :: P.Precedence , _ideTypeOpAssociativity :: P.Associativity , _ideTypeOpKind :: Maybe P.SourceType - } deriving (Show, Eq, Ord) + } deriving (Show, Eq, Ord, Generic, Hashable) _IdeDeclValue :: Traversal' IdeDeclaration IdeValue _IdeDeclValue f (IdeDeclValue x) = map IdeDeclValue (f x) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index a1fed6b5ec..7c4c27e08e 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -21,10 +21,9 @@ import Data.Aeson.TH (deriveJSON) import Data.Text (Text) import Data.Text qualified as T import Data.Int (Int64) -import Data.Hashable (Hashable) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) -import Language.PureScript.Interner (Interned, uninternText, internText, getInternedHash) +import Language.PureScript.Interner (Interned, uninternText, internText) import Data.Hashable (Hashable (..)) -- | A sum of the possible name types, useful for error and lint messages. @@ -250,27 +249,36 @@ toMaybeModuleName (BySourcePos _) = Nothing -- | -- A qualified name, i.e. a name with an optional module name -- -data Qualified a = Qualified QualifiedBy a Int +data Qualified a = Qualified' QualifiedBy a Int deriving (Functor, Foldable, Traversable, Generic) +pattern Qualified qb a <- Qualified' qb a _ where + Qualified qb a = mkQualified_ qb a + + instance Show a => Show (Qualified a) where - show (Qualified qb a _) = case qb of + show (Qualified qb a) = case qb of BySourcePos _ -> show a ByModuleName mn -> T.unpack (runModuleName mn) <> "." <> show a instance NFData a => NFData (Qualified a) -instance Serialise a => Serialise (Qualified a) + +instance (Serialise a, Hashable a) => Serialise (Qualified a) where + encode (Qualified qb a) = encode $ Qualified' qb a + decode = do + Qualified qb a <- decode + pure $ mkQualified_ qb a instance Eq a => Eq (Qualified a) where - (Qualified qb a _) == (Qualified qb' a' _) = qb == qb' && a == a' + (Qualified q a _) == (Qualified q' a' _) = (q == q' && a == a') instance Ord a => Ord (Qualified a) where - compare (Qualified qb a1 _) (Qualified qb' a2 _) = case compare qb qb' of + compare (Qualified qb a1 _) (Qualified qb' a2 _) = case compare qb qb' of EQ -> compare a1 a2 other -> other instance Hashable a => Hashable (Qualified a) where - hashWithSalt s (Qualified _ a h) = hashWithSalt s h `hashWithSalt` a + hashWithSalt s (Qualified _ _ h) = hashWithSalt s h showQualified :: (a -> Text) -> Qualified a -> Text @@ -290,11 +298,11 @@ qualify _ (Qualified (ByModuleName m) a _) = (m, a) -- | -- Makes a qualified value from a name and module name. -- -mkQualified :: a -> ModuleName -> Qualified a -mkQualified name mn@(ModuleName i) = Qualified (ByModuleName mn) name (getInternedHash i) +mkQualified :: Hashable a => a -> ModuleName -> Qualified a +mkQualified name mn = Qualified (ByModuleName mn) name (hashWithSalt 1 mn `hashWithSalt` name) -mkQualified_ :: QualifiedBy -> a -> Qualified a -mkQualified_ qb name = Qualified qb name (hash qb) +mkQualified_ :: Hashable a => QualifiedBy -> a -> Qualified a +mkQualified_ qb name = Qualified qb name (hashWithSalt 1 qb `hashWithSalt` name) -- | Remove the module name from a qualified name diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 3ab9914de1..a7844cfe6d 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -34,6 +34,7 @@ import Language.PureScript.Sugar.Names.Exports (findExportable, resolveExports) import Language.PureScript.Sugar.Names.Imports (resolveImports, resolveModuleImport) import Language.PureScript.Traversals (defS, sndM) import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), everywhereOnTypesM) +import Data.Hashable (Hashable) -- | -- Replaces all local names with qualified names. @@ -406,7 +407,7 @@ renameInModule imports (Module modSS coms mn decls exps) = -- qualified references are replaced with their canonical qualified names -- (e.g. M.Map -> Data.Map.Map). update - :: (Ord a) + :: (Ord a, Hashable a) => M.Map (Qualified a) [ImportRecord a] -> (a -> Name) -> Qualified a diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index ee5c00badf..a1a57b5d24 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -20,6 +20,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow) import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, mkQualified_) import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), envModuleExports, nullImports) +import Data.Hashable (Hashable) type ImportDef = (SourceSpan, ImportDeclarationType, Maybe ModuleName) @@ -210,7 +211,7 @@ resolveImport importModule exps imps impQual = resolveByType -- Add something to an import resolution list updateImports - :: Ord a + :: (Ord a, Hashable a) => M.Map (Qualified a) [ImportRecord a] -> M.Map a b -> (b -> ExportSource) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 789a7afbad..324cdfc064 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -47,6 +47,7 @@ import Language.PureScript.TypeChecker.Unify (varIfUnknown) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), containsForAll, eqType, everythingOnTypes, overConstraintArgs, srcInstanceType, unapplyTypes) import Data.HashMap.Strict qualified as HM +import Data.Hashable (Hashable) addDataType :: ModuleName @@ -608,7 +609,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = toImportDecl (sa, moduleName, importDeclarationType, asModuleName, _) = ImportDeclaration sa moduleName importDeclarationType asModuleName - qualify' :: a -> Qualified a + qualify' :: Hashable a => a -> Qualified a qualify' = mkQualified_ (ByModuleName mn) getSuperClassExportCheck = do diff --git a/tests/TestAst.hs b/tests/TestAst.hs index da7d24fecf..4313055550 100644 --- a/tests/TestAst.hs +++ b/tests/TestAst.hs @@ -73,7 +73,7 @@ genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where genConstraintData :: Gen ConstraintData genConstraintData = genericArbitraryUG generatorEnvironment - genQualified :: forall b. (Text -> b) -> Gen (Qualified b) + genQualified :: forall b. Hashable b => (Text -> b) -> Gen (Qualified b) genQualified ctor = mkQualified_ ByNullSourcePos . ctor <$> genText genSkolemScope :: Gen SkolemScope From cf755a73c1b63bfd29ca629cf82b128f7e116639 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Sun, 18 May 2025 21:08:45 +0000 Subject: [PATCH 09/19] Compiles but is super slow --- src/Language/PureScript/AST/Declarations.hs | 8 +- src/Language/PureScript/AST/Exported.hs | 3 +- src/Language/PureScript/AST/Utils.hs | 4 +- src/Language/PureScript/CST/Convert.hs | 2 +- src/Language/PureScript/CodeGen/JS.hs | 17 +-- src/Language/PureScript/Constants/Libs.hs | 4 +- src/Language/PureScript/Constants/TH.hs | 24 +--- src/Language/PureScript/CoreFn/CSE.hs | 8 +- src/Language/PureScript/CoreFn/Desugar.hs | 11 +- src/Language/PureScript/CoreFn/FromJSON.hs | 2 +- src/Language/PureScript/CoreFn/Laziness.hs | 6 +- src/Language/PureScript/CoreFn/ToJSON.hs | 7 +- .../PureScript/Docs/Convert/Single.hs | 6 +- .../PureScript/Docs/RenderedCode/Types.hs | 9 +- src/Language/PureScript/Docs/Types.hs | 4 +- src/Language/PureScript/Errors.hs | 57 ++++---- src/Language/PureScript/Externs.hs | 4 +- src/Language/PureScript/Hierarchy.hs | 2 +- src/Language/PureScript/Ide/Error.hs | 2 +- src/Language/PureScript/Ide/State.hs | 8 +- .../PureScript/Interactive/Printer.hs | 9 +- src/Language/PureScript/Interner.hs | 4 +- src/Language/PureScript/Linter.hs | 6 +- src/Language/PureScript/Linter/Imports.hs | 11 +- src/Language/PureScript/Make/ExternsDiff.hs | 14 +- src/Language/PureScript/Names.hs | 135 ++++++++++++------ src/Language/PureScript/PSString.hs | 5 +- src/Language/PureScript/Pretty/Values.hs | 4 +- src/Language/PureScript/Renamer.hs | 4 +- .../PureScript/Sugar/BindingGroups.hs | 14 +- src/Language/PureScript/Sugar/Names.hs | 12 +- src/Language/PureScript/Sugar/Names/Env.hs | 13 +- .../PureScript/Sugar/Names/Exports.hs | 15 +- .../PureScript/Sugar/Names/Imports.hs | 4 +- src/Language/PureScript/Sugar/Operators.hs | 21 +-- .../PureScript/Sugar/Operators/Binders.hs | 4 +- .../PureScript/Sugar/Operators/Expr.hs | 4 +- .../PureScript/Sugar/Operators/Types.hs | 4 +- src/Language/PureScript/Sugar/TypeClasses.hs | 4 +- src/Language/PureScript/TypeChecker.hs | 18 +-- .../PureScript/TypeChecker/Deriving.hs | 6 +- .../PureScript/TypeChecker/Entailment.hs | 8 +- .../TypeChecker/Entailment/Coercible.hs | 4 +- src/Language/PureScript/TypeChecker/Monad.hs | 10 +- src/Language/PureScript/TypeChecker/Roles.hs | 2 +- .../PureScript/TypeChecker/TypeSearch.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 6 +- src/Language/PureScript/Types.hs | 10 +- tests/TestAst.hs | 4 +- 49 files changed, 299 insertions(+), 246 deletions(-) diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index fae45d5762..be7d4c003b 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -26,7 +26,7 @@ import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Types (SourceConstraint, SourceType) import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), toMaybeModuleName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), toMaybeModuleName, mkQualified_) import Language.PureScript.Roles (Role) import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Comments (Comment) @@ -141,7 +141,7 @@ getModuleDeclarations (Module _ _ _ declarations _) = declarations -- (See #2197) -- addDefaultImport :: Qualified ModuleName -> Module -> Module -addDefaultImport (Qualified toImportAs toImport _) m@(Module ss coms mn decls exps) = +addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs' : decls) exps where @@ -856,8 +856,8 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDe isTrueExpr :: Expr -> Bool isTrueExpr (Literal _ (BooleanLiteral True)) = True -isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Prelude")) (Ident "otherwise") _)) = True -isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Data.Boolean")) (Ident "otherwise") _)) = True +isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Prelude")) (Ident "otherwise"))) = True +isTrueExpr (Var _ (Qualified (ByModuleName (ModuleName "Data.Boolean")) (Ident "otherwise"))) = True isTrueExpr (TypedValue _ e _) = isTrueExpr e isTrueExpr (PositionedValue _ _ e) = isTrueExpr e isTrueExpr _ = False diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 8ca960bb95..97778ee101 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -15,6 +15,7 @@ import Data.Map qualified as M import Language.PureScript.AST.Declarations (DataConstructorDeclaration(..), Declaration(..), DeclarationRef(..), Module(..), declName, declRefName, flattenDecls) import Language.PureScript.Types (Constraint(..), Type(..), everythingOnTypes) import Language.PureScript.Names (ModuleName, Name(..), ProperName, ProperNameType(..), Qualified, coerceProperName, disqualify, isQualified, isQualifiedWith) +import Data.Hashable (Hashable) -- | -- Return a list of all declarations which are exported from a module. @@ -89,7 +90,7 @@ filterInstances mn (Just exps) = | otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs -- Check that a qualified name is qualified for a different module - checkQual :: Qualified a -> Bool + checkQual :: (Show a, Hashable a) => Qualified a -> Bool checkQual q = isQualified q && not (isQualifiedWith mn q) typeName :: DeclarationRef -> Maybe (ProperName 'TypeName) diff --git a/src/Language/PureScript/AST/Utils.hs b/src/Language/PureScript/AST/Utils.hs index 6e774d6625..ff560a03ce 100644 --- a/src/Language/PureScript/AST/Utils.hs +++ b/src/Language/PureScript/AST/Utils.hs @@ -3,7 +3,7 @@ module Language.PureScript.AST.Utils where import Protolude import Language.PureScript.AST (Binder(..), CaseAlternative, Expr(..), GuardedExpr, Literal, pattern MkUnguarded, nullSourceSpan) -import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, mkQualified_) +import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), byMaybeModuleName, mkQualified_) import Language.PureScript.Types (SourceType, Type(..)) lam :: Ident -> Expr -> Expr @@ -53,7 +53,7 @@ unwrapTypeConstructor :: SourceType -> Maybe UnwrappedTypeConstructor unwrapTypeConstructor = go [] [] where go kargs args = \case - TypeConstructor _ (Qualified (ByModuleName mn) tyCon _) -> Just (UnwrappedTypeConstructor mn tyCon kargs args) + TypeConstructor _ (Qualified (ByModuleName mn) tyCon) -> Just (UnwrappedTypeConstructor mn tyCon kargs args) TypeApp _ ty arg -> go kargs (arg : args) ty KindApp _ ty karg -> go (karg : kargs) args ty _ -> Nothing diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 8ab21a53dc..c812c92077 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -90,7 +90,7 @@ moduleName = \case go [] = Nothing go ns = Just $ N.moduleNameFromString $ Text.intercalate "." ns -qualified :: Hashable a=> QualifiedName a -> N.Qualified a +qualified :: (Show a, Hashable a) => QualifiedName a -> N.Qualified a qualified q = N.mkQualified_ qb (qualName q) where qb = maybe N.ByNullSourcePos N.ByModuleName $ qualModule q diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index b242bddc83..3849434151 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -26,6 +26,7 @@ import Data.Monoid (Any(..)) import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as T +import Data.Hashable (Hashable) import Language.PureScript.AST.SourcePos (SourceSpan, displayStartEndPos) import Language.PureScript.CodeGen.JS.Common as Common @@ -39,7 +40,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), MultipleErrors(..), rethrow, errorMessage, errorMessage', rethrowWithPosition, addHint) -import Language.PureScript.Names (Ident(..), ModuleName, Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified, runProperName) +import Language.PureScript.Names (Ident(..), ModuleName, pattern Qualified, Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified, runProperName) import Language.PureScript.Options (CodegenTarget(..), Options(..)) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) @@ -262,7 +263,7 @@ moduleBindToJs mn = bindToJs guessEffects :: Expr Ann -> AST.InitializerEffects guessEffects = \case - Var _ (Qualified (BySourcePos _) _ _) -> NoEffects + Var _ (Qualified (BySourcePos _) _) -> NoEffects App (_, _, Just IsSyntheticApp) _ _ -> NoEffects _ -> UnknownEffects @@ -318,7 +319,7 @@ moduleBindToJs mn = bindToJs unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann]) unApp (App _ val arg) args = unApp val (arg : args) unApp other args = (other, args) - valueToJs' (Var (_, _, Just IsForeign) qi@(Qualified (ByModuleName mn') ident _)) = + valueToJs' (Var (_, _, Just IsForeign) qi@(Qualified (ByModuleName mn') ident)) = return $ if mn' == mn then foreignIdent ident else varToJs qi @@ -387,15 +388,15 @@ moduleBindToJs mn = bindToJs -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable. varToJs :: Qualified Ident -> AST - varToJs (Qualified (BySourcePos _) ident _) = var ident + varToJs (Qualified (BySourcePos _) ident) = var ident varToJs qual = qualifiedToJS id qual -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. - qualifiedToJS :: (a -> Ident) -> Qualified a -> AST - qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a _) = AST.Var Nothing . runIdent $ f a - qualifiedToJS f (Qualified (ByModuleName mn') a _) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a - qualifiedToJS f (Qualified _ a _) = AST.Var Nothing $ identToJs (f a) + qualifiedToJS :: (Show a, Hashable a) => (a -> Ident) -> Qualified a -> AST + qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a) = AST.Var Nothing . runIdent $ f a + qualifiedToJS f (Qualified (ByModuleName mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a + qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) foreignIdent :: Ident -> AST foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing FFINamespace) diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index 831cd71493..b59cd69de6 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -9,7 +9,7 @@ import Protolude qualified as P import Data.String (IsString) import Language.PureScript.Constants.TH qualified as TH import Language.PureScript.PSString (PSString) -import Language.PureScript.Names (Ident (..), Qualified (..), QualifiedBy (..)) +import Language.PureScript.Names (Ident (..), Qualified (..), QualifiedBy (..), pattern Qualified, Qualified(..)) -- Core lib values @@ -276,4 +276,4 @@ $(TH.declare do ) pattern IsSymbolDict :: Qualified Ident -pattern IsSymbolDict = Qualified (ByModuleName M_Data_Symbol) (Ident "IsSymbol$Dict") (-7980125151384708176) +pattern IsSymbolDict = Qualified (ByModuleName M_Data_Symbol) (Ident "IsSymbol$Dict") diff --git a/src/Language/PureScript/Constants/TH.hs b/src/Language/PureScript/Constants/TH.hs index c568d0ce87..ed1f3e1e2c 100644 --- a/src/Language/PureScript/Constants/TH.hs +++ b/src/Language/PureScript/Constants/TH.hs @@ -73,10 +73,9 @@ import Control.Lens (over, _head) import Control.Monad.Trans.RWS (RWS, execRWS) import Control.Monad.Trans.Writer (Writer, execWriter) import Control.Monad.Writer.Class (tell) -import Data.String (String, fromString) -import Language.Haskell.TH (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL, nameBase, Lit (IntegerL)) -import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, properNameFromString) -import Data.Text qualified as T +import Data.String (String) +import Language.Haskell.TH (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL) +import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), Qualified (..)) -- | Generate pattern synonyms corresponding to the provided PureScript -- declarations. @@ -193,29 +192,20 @@ mkPrefixedName tag prefix = mkName . (tag <>) . camelAppend prefix -- pattern FunctionFoo :: Qualified (ProperName 'TypeName) -- pattern FunctionFoo = Qualified (ByModuleName M_Data_Foo) (ProperName "Foo") mkPnPat :: Q Type -> VarToDec -mkPnPat pnType mn prefix str = do - let modNameStr = nameBase mn - -- Compute the hash - let q = ByModuleName (moduleNameFromString (fromString modNameStr)) - let hashValue = toInteger (hashWithSalt 1 q `hashWithSalt` properNameFromString (T.pack str)) +mkPnPat pnType mn prefix str = typedPatSyn (mkName $ cap prefix <> str) [t| Qualified (ProperName $pnType) |] - [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str)) $(litP $ IntegerL hashValue) |] + [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str))|] -- M_Data_Foo -> "function" -> "foo" -> -- pattern I_functionFoo :: Qualified Ident -- pattern I_functionFoo = Qualified (ByModuleName M_Data_Foo) (Ident "foo") mkIdentDec :: VarToDec -mkIdentDec mn prefix str = do - let modNameStr = nameBase mn - -- Compute the hash - let q = ByModuleName (moduleNameFromString (fromString modNameStr)) - let hashValue = toInteger (hashWithSalt 1 q `hashWithSalt` Ident (T.pack str)) - +mkIdentDec mn prefix str = typedPatSyn (mkPrefixedName "I_" prefix str) [t| Qualified Ident |] - [p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) $(litP $ IntegerL hashValue) |] + [p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) |] -- M_Data_Foo -> "function" -> "foo" -> -- pattern P_functionFoo :: forall a. (Eq a, IsString a) => (ModuleName, a) diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index d6bb70786b..6d5c3aeae7 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -26,7 +26,7 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) import Language.PureScript.CoreFn.Meta (Meta(IsSyntheticApp)) import Language.PureScript.CoreFn.Traversals (everywhereOnValues, traverseCoreFn) import Language.PureScript.Environment (dictTypeName) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, pattern Qualified, Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString, mkQualified_) import Language.PureScript.PSString (decodeString) -- | @@ -254,7 +254,7 @@ generateIdentFor d e = at d . non mempty . at e %%<~ \case -> decodedStr <> "IsSymbol" | otherwise -> nameHint v1 - Var _ (Qualified _ ident _) + Var _ (Qualified _ ident) | Ident name <- ident -> name | GenIdent (Just name) _ <- ident -> name Accessor _ prop _ @@ -270,7 +270,7 @@ nullAnn = (nullSourceSpan, [], Nothing) replaceLocals :: M.Map Ident (Expr Ann) -> [Bind Ann] -> [Bind Ann] replaceLocals m = if M.null m then identity else map f' where (f', g', _) = everywhereOnValues identity f identity - f e@(Var _ (Qualified _ ident _)) = maybe e g' $ ident `M.lookup` m + f e@(Var _ (Qualified _ ident)) = maybe e g' $ ident `M.lookup` m f e = e -- | @@ -339,7 +339,7 @@ summarizeName => ModuleName -> Qualified Ident -> m () -summarizeName mn (Qualified mn' ident _) = do +summarizeName mn (Qualified mn' ident) = do m <- view bound let (s, bt) = fromMaybe (0, NonRecursive) $ diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 8718a3882e..abad09ebc6 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -23,11 +23,12 @@ import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), getQual, runProperName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), getQual, runProperName, mkQualified_) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST qualified as A import Language.PureScript.Constants.Prim qualified as C +import Data.Hashable (Hashable) -- | Desugars a module from AST to CoreFn representation. moduleToCoreFn :: Environment -> A.Module -> Module Ann @@ -113,7 +114,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = v1' = exprToCoreFn ss [] Nothing v1 v2' = exprToCoreFn ss [] Nothing v2 isDictCtor = \case - A.Constructor _ (Qualified _ name _) -> isDictTypeName name + A.Constructor _ (Qualified _ name) -> isDictTypeName name _ -> False isSynthetic = \case A.App v3 v4 -> isDictCtor v3 || isSynthetic v3 && isSynthetic v4 @@ -168,7 +169,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = NullBinder (ss, com, Nothing) binderToCoreFn _ com (A.VarBinder ss name) = VarBinder (ss, com, Nothing) name - binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _ _) bs) = + binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (mkQualified_ mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) binderToCoreFn _ com (A.NamedBinder ss name b) = @@ -214,7 +215,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = typeConstructor :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) -> (ModuleName, ProperName 'TypeName) - typeConstructor (Qualified (ByModuleName mn') _ _, (_, tyCtor, _, _)) = (mn', tyCtor) + typeConstructor (Qualified (ByModuleName mn') _ , (_, tyCtor, _, _)) = (mn', tyCtor) typeConstructor _ = internalError "Invalid argument to typeConstructor" -- | Find module names from qualified references to values. This is used to @@ -240,7 +241,7 @@ findQualModules decls = fqBinders (A.ConstructorBinder _ q _) = getQual' q fqBinders _ = [] - getQual' :: Qualified a -> [ModuleName] + getQual' :: (Show a, Hashable a) => Qualified a -> [ModuleName] getQual' = maybe [] return . getQual -- | Desugars import declarations from AST to CoreFn representation. diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index ae057d6b15..529024b400 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -111,7 +111,7 @@ identFromJSON = withText "Ident" $ \case properNameFromJSON :: Value -> Parser (ProperName a) properNameFromJSON = fmap properNameFromString . parseJSON -qualifiedFromJSON :: Hashable a => (Text -> a) -> Value -> Parser (Qualified a) +qualifiedFromJSON :: Show a => Hashable a => (Text -> a) -> Value -> Parser (Qualified a) qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj where qualifiedFromObj o = diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs index b3ec183c91..b87a3274f6 100644 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -20,7 +20,7 @@ import Language.PureScript.AST.SourcePos (SourcePos(..), SourceSpan(..), nullSou import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.CoreFn (Ann, Bind, Expr(..), Literal(..), Meta(..), ssAnn, traverseCoreFn) import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, Qualified(..), QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, pattern Qualified, Qualified(..), QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName, mkQualified_) import Language.PureScript.PSString (mkString) -- This module is responsible for ensuring that the bindings in recursive @@ -432,7 +432,7 @@ applyLazinessTransform mn rawItems = let -- A B (keys) C (keys) D findReferences :: Expr Ann -> IM.MonoidalIntMap (IM.MonoidalIntMap (Ap Maybe (Max Int))) findReferences = (getConst .) . onVarsWithDelayAndForce $ \delay force _ -> \case - Qualified qb ident _ | all (== mn) (toMaybeModuleName qb), Just i <- ident `S.lookupIndex` names + Qualified qb ident | all (== mn) (toMaybeModuleName qb), Just i <- ident `S.lookupIndex` names -> Const . IM.singleton delay . IM.singleton i $ coerceForce force _ -> Const IM.empty @@ -516,7 +516,7 @@ applyLazinessTransform mn rawItems = let Nothing -> pair Just m -> let rewriteExpr = (runIdentity .) . onVarsWithDelayAndForce $ \delay _ ann -> pure . \case - Qualified qb ident' _ | all (== mn) (toMaybeModuleName qb), any (all (>= Max delay) . getAp) $ ident' `M.lookup` m + Qualified qb ident' | all (== mn) (toMaybeModuleName qb), any (all (>= Max delay) . getAp) $ ident' `M.lookup` m -> makeForceCall ann ident' q -> Var ann q in (ident, rewriteExpr <$> item) diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 121519487f..07e2d33e4b 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -23,8 +23,9 @@ import Data.Text qualified as T import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Meta(..), Module(..)) -import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName, runProperName) +import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), pattern Qualified, Qualified(..), QualifiedBy(..), runIdent, runModuleName, runProperName) import Language.PureScript.PSString (PSString) +import Data.Hashable (Hashable) constructorTypeToJSON :: ConstructorType -> Value constructorTypeToJSON ProductType = toJSON "ProductType" @@ -101,8 +102,8 @@ identToJSON = toJSON . runIdent properNameToJSON :: ProperName a -> Value properNameToJSON = toJSON . runProperName -qualifiedToJSON :: (a -> Text) -> Qualified a -> Value -qualifiedToJSON f (Qualified qb a _) = +qualifiedToJSON :: Show a => Hashable a => (a -> Text) -> Qualified a -> Value +qualifiedToJSON f (Qualified qb a) = case qb of ByModuleName mn -> object [ "moduleName" .= moduleNameToJSON mn diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 36f25a9421..f217d7d687 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -192,16 +192,16 @@ convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ _ constraints clas where classNameString = unQual className typeNameStrings = ordNub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) - unQual x = let (P.Qualified _ y _) = x in P.runProperName y + unQual x = let (P.Qualified _ y) = x in P.runProperName y extractProperNames (P.TypeConstructor _ n) = [unQual n] extractProperNames _ = [] childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance (fmap ($> ()) constraints) (classApp $> ())) classApp = foldl' P.srcTypeApp (P.srcTypeConstructor (fmap P.coerceProperName className)) tys -convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias _) _) title = +convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title = Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.mkQualified_ mn (Right alias))) -convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias _) _) title = +convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title = Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.mkQualified_ mn (Left alias))) convertDeclaration (P.KindDeclaration sa keyword _ kind) title = Just $ Left ([(title, AugmentType), (title, AugmentClass)], AugmentKindSig ksi) diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index fef389ee92..950d75f993 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -45,8 +45,9 @@ import Data.Text qualified as T import Data.ByteString.Lazy qualified as BS import Data.Text.Encoding qualified as TE -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName, runProperName, properNameFromString, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName, runProperName, properNameFromString, mkQualified_) import Language.PureScript.AST (Associativity(..)) +import Data.Hashable (Hashable) -- | Given a list of actions, attempt them all, returning the first success. -- If all the actions fail, 'tryAll' returns the first argument. @@ -116,9 +117,9 @@ maybeToContainingModule :: Maybe ModuleName -> ContainingModule maybeToContainingModule Nothing = ThisModule maybeToContainingModule (Just mn) = OtherModule mn -fromQualified :: Qualified a -> (ContainingModule, a) -fromQualified (Qualified (ByModuleName mn) x _) = (OtherModule mn, x) -fromQualified (Qualified _ x _) = (ThisModule, x) +fromQualified :: Show a => Hashable a => Qualified a -> (ContainingModule, a) +fromQualified (Qualified (ByModuleName mn) x) = (OtherModule mn, x) +fromQualified (Qualified _ x) = (ThisModule, x) data Link = NoLink diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 3ff86b7bca..c4e6cbecaa 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -273,13 +273,13 @@ isType Declaration{..} = isValueAlias :: Declaration -> Bool isValueAlias Declaration{..} = case declInfo of - AliasDeclaration _ (P.Qualified _ d _) -> isRight d + AliasDeclaration _ (P.Qualified _ d) -> isRight d _ -> False isTypeAlias :: Declaration -> Bool isTypeAlias Declaration{..} = case declInfo of - AliasDeclaration _ (P.Qualified _ d _) -> isLeft d + AliasDeclaration _ (P.Qualified _ d) -> isLeft d _ -> False -- | Discard any children which do not satisfy the given predicate. diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index e444a5fa85..3837c84bba 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -56,6 +56,8 @@ import System.Console.ANSI qualified as ANSI import System.FilePath (makeRelative) import Text.PrettyPrint.Boxes qualified as Box import Witherable (wither) +import Data.Hashable (hash) +import Debug.Trace (trace) -- | A type of error messages data SimpleErrorMessage @@ -766,35 +768,35 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon line $ "The role declaration for " <> markCode (runProperName nm) <> " should follow its definition." renderSimpleErrorMessage (RedefinedIdent name) = line $ "The value " <> markCode (showIdent name) <> " has been defined multiple times" - renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)) _)) | i `elem` [ C.S_bind, C.S_discard ] = + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident i)))) | i `elem` [ C.S_bind, C.S_discard ] = line $ "Unknown " <> printName name <> ". You're probably using do-notation, which the compiler replaces with calls to the " <> markCode "bind" <> " and " <> markCode "discard" <> " functions. Please import " <> markCode i <> " from module " <> markCode "Prelude" - renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident C.S_negate)) _)) = + renderSimpleErrorMessage (UnknownName name@(Qualified (BySourcePos _) (IdentName (Ident C.S_negate)))) = line $ "Unknown " <> printName name <> ". You're probably using numeric negation (the unary " <> markCode "-" <> " operator), which the compiler replaces with calls to the " <> markCode C.S_negate <> " function. Please import " <> markCode C.S_negate <> " from module " <> markCode "Prelude" renderSimpleErrorMessage (UnknownName name) = line $ "Unknown " <> printName name renderSimpleErrorMessage (UnknownImport mn name) = - paras [ line $ "Cannot import " <> printName (Qualified ByNullSourcePos name 0) <> " from module " <> markCode (runModuleName mn) + paras [ line $ "Cannot import " <> printName (Qualified ByNullSourcePos name) <> " from module " <> markCode (runModuleName mn) , line "It either does not exist or the module does not export it." ] renderSimpleErrorMessage (UnknownImportDataConstructor mn tcon dcon) = line $ "Module " <> runModuleName mn <> " does not export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) renderSimpleErrorMessage (UnknownExport name) = - line $ "Cannot export unknown " <> printName (Qualified ByNullSourcePos name 0 ) + line $ "Cannot export unknown " <> printName (Qualified ByNullSourcePos name) renderSimpleErrorMessage (UnknownExportDataConstructor tcon dcon) = line $ "Cannot export data constructor " <> markCode (runProperName dcon) <> " for type " <> markCode (runProperName tcon) <> ", as it has not been declared." renderSimpleErrorMessage (ScopeConflict nm ms) = - paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified ByNullSourcePos nm 0) <> " from the following modules:" + paras [ line $ "Conflicting definitions are in scope for " <> printName (Qualified ByNullSourcePos nm) <> " from the following modules:" , indent $ paras $ map (line . markCode . runModuleName) ms ] renderSimpleErrorMessage (ScopeShadowing nm exmn ms) = - paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified ByNullSourcePos nm 0) <> " from the following open imports:" + paras [ line $ "Shadowed definitions are in scope for " <> printName (Qualified ByNullSourcePos nm) <> " from the following open imports:" , indent $ paras $ map (line . markCode . ("import " <>) . runModuleName) ms , line $ "These will be ignored and the " <> case exmn of Just exmn' -> "declaration from " <> markCode (runModuleName exmn') <> " will be used." Nothing -> "local declaration will be used." ] renderSimpleErrorMessage (DeclConflict new existing) = - line $ "Declaration for " <> printName (Qualified ByNullSourcePos new 0) <> " conflicts with an existing " <> nameType existing <> " of the same name." + line $ "Declaration for " <> printName (Qualified ByNullSourcePos new) <> " conflicts with an existing " <> nameType existing <> " of the same name." renderSimpleErrorMessage (ExportConflict new existing) = line $ "Export for " <> printName new <> " conflicts with " <> printName existing renderSimpleErrorMessage (DuplicateModule mn) = @@ -862,11 +864,11 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon ] renderSimpleErrorMessage (TypesDoNotUnify u1 u2) = let (row1Box, row2Box) = printRows u1 u2 - - in paras [ line "Could not match type" + in paras [ line "Could not match type" , row1Box , line "with type" , row2Box + , line $ "Hashes are: " <> (T.pack $ show $ u1) <> " and " <> (T.pack $ show $ u2) ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = @@ -874,6 +876,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon , markCodeBox $ indent $ prettyType k1 , line "with kind" , markCodeBox $ indent $ prettyType k2 + , line $ "Hashes are: " <> (T.pack $ show $ hash k1) <> " and " <> (T.pack $ show $ hash k2) ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = paras [ line "Could not match constrained type" @@ -1224,10 +1227,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon line $ "Duplicate import of " <> markCode (prettyPrintImport name imp qual) renderSimpleErrorMessage (DuplicateImportRef name) = - line $ "Import list contains multiple references to " <> printName (Qualified ByNullSourcePos name 0) + line $ "Import list contains multiple references to " <> printName (Qualified ByNullSourcePos name) renderSimpleErrorMessage (DuplicateExportRef name) = - line $ "Export list contains multiple references to " <> printName (Qualified ByNullSourcePos name 0) + line $ "Export list contains multiple references to " <> printName (Qualified ByNullSourcePos name) renderSimpleErrorMessage (IntOutOfRange value backend lo hi) = paras [ line $ "Integer value " <> markCode (T.pack (show value)) <> " is out of range for the " <> backend <> " backend." @@ -1673,21 +1676,21 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon nameType (ModName _) = "module" runName :: Qualified Name -> Text - runName (Qualified qb (IdentName name) _) = - showQualified showIdent (Qualified qb name 0) - runName (Qualified qb (ValOpName op) _) = - showQualified showOp (Qualified qb op 0) - runName (Qualified qb (TyName name) _) = - showQualified runProperName (Qualified qb name 0) - runName (Qualified qb (TyOpName op) _) = - showQualified showOp (Qualified qb op 0) - runName (Qualified qb (DctorName name) _) = - showQualified runProperName (Qualified qb name 0) - runName (Qualified qb (TyClassName name) _) = - showQualified runProperName (Qualified qb name 0) - runName (Qualified (BySourcePos _) (ModName name) _) = + runName (Qualified qb (IdentName name)) = + showQualified showIdent (Qualified qb name) + runName (Qualified qb (ValOpName op)) = + showQualified showOp (Qualified qb op) + runName (Qualified qb (TyName name)) = + showQualified runProperName (Qualified qb name) + runName (Qualified qb (TyOpName op)) = + showQualified showOp (Qualified qb op) + runName (Qualified qb (DctorName name)) = + showQualified runProperName (Qualified qb name) + runName (Qualified qb (TyClassName name)) = + showQualified runProperName (Qualified qb name) + runName (Qualified (BySourcePos _) (ModName name)) = runModuleName name - runName (Qualified _ ModName{} _) = + runName (Qualified _ ModName{}) = internalError "qualified ModName in runName" prettyDepth :: Int @@ -1790,7 +1793,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon prettyInstanceName :: Qualified (Either SourceType Ident) -> Box.Box prettyInstanceName = \case - Qualified qb (Left ty) _ -> + Qualified qb (Left ty) -> "instance " Box.<> (case qb of ByModuleName mn -> "in module " @@ -1801,7 +1804,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon Box.<> markCodeBox (prettyType ty) Box.<> " " Box.<> (line . displayStartEndPos . fst $ getAnnForType ty) - Qualified mn (Right inst) _ -> line . markCode . showQualified showIdent $ mkQualified_ mn inst + Qualified mn (Right inst) -> line . markCode . showQualified showIdent $ mkQualified_ mn inst -- As of this writing, this function assumes that all provided SourceSpans -- are non-overlapping (except for exact duplicates) and span no line breaks. A diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index a2a64e14b2..94abc247b4 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -35,7 +35,7 @@ import Language.PureScript.AST (Associativity, Declaration(..), DeclarationRef(. import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType, Environment(..), FunctionalDependency, NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..), dictTypeName, makeTypeClassData) -import Language.PureScript.Names (Ident, ModuleName, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, isPlainIdent, mkQualified_) +import Language.PureScript.Names (Ident, ModuleName, OpName, OpNameType(..), ProperName, ProperNameType(..), QualifiedBy(..), coerceProperName, isPlainIdent, mkQualified_, Qualified) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) import Language.PureScript.Types (SourceConstraint, SourceType, srcInstanceType) @@ -200,7 +200,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar CompilerNamed -> Just $ srcInstanceType ss vars className tys UserNamed -> Nothing - qual :: Hashable a => a -> Qualified a + qual :: (Show a, Hashable a) => a -> Qualified a qual = mkQualified_ (ByModuleName efModuleName) -- | Generate an externs file for all declarations in a module. diff --git a/src/Language/PureScript/Hierarchy.hs b/src/Language/PureScript/Hierarchy.hs index 6e86a63e56..09fb792bda 100644 --- a/src/Language/PureScript/Hierarchy.hs +++ b/src/Language/PureScript/Hierarchy.hs @@ -80,6 +80,6 @@ typeClassEpilogue = "\n}" superClasses :: P.Declaration -> [SuperMap] superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) = - fmap (\(P.Constraint _ (P.Qualified _ super _) _ _ _) -> SuperMap (Right (super, sub))) supers + fmap (\(P.Constraint _ (P.Qualified _ super) _ _ _) -> SuperMap (Right (super, sub))) supers superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)] superClasses _ = [] diff --git a/src/Language/PureScript/Ide/Error.hs b/src/Language/PureScript/Ide/Error.hs index 437d947d45..8a23f574e0 100644 --- a/src/Language/PureScript/Ide/Error.hs +++ b/src/Language/PureScript/Ide/Error.hs @@ -63,7 +63,7 @@ encodeRebuildErrors files = toJSON . map encodeRebuildError . P.runMultipleError ]) value) insertTSCompletions _ _ _ v = v - identCompletion (P.Qualified mn i _, ty) = + identCompletion (P.Qualified mn i, ty) = Completion { complModule = maybe "" P.runModuleName $ P.toMaybeModuleName mn , complIdentifier = i diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs index 3592e17d7b..d2868bbae6 100644 --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -357,7 +357,7 @@ resolveInstances externs declarations = where extractInstances mn P.EDInstance{..} = case edInstanceClassName of - P.Qualified (P.ByModuleName classModule) className _ -> + P.Qualified (P.ByModuleName classModule) className -> Just (IdeInstance mn edInstanceName edInstanceTypes @@ -401,14 +401,14 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) & foldMap (map discardAnn) resolveOperator (IdeDeclValueOperator op) - | (P.Qualified (P.ByModuleName mn) (Left ident) _) <- op ^. ideValueOpAlias = + | (P.Qualified (P.ByModuleName mn) (Left ident)) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclValue) & filter (anyOf ideValueIdent (== ident)) & map (view ideValueType) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) - | (P.Qualified (P.ByModuleName mn) (Right dtor) _) <- op ^. ideValueOpAlias = + | (P.Qualified (P.ByModuleName mn) (Right dtor)) <- op ^. ideValueOpAlias = let t = getDeclarations mn & mapMaybe (preview _IdeDeclDataConstructor) & filter (anyOf ideDtorName (== dtor)) @@ -416,7 +416,7 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator) & listToMaybe in IdeDeclValueOperator (op & ideValueOpType .~ t) resolveOperator (IdeDeclTypeOperator op) - | P.Qualified (P.ByModuleName mn) properName _ <- op ^. ideTypeOpAlias = + | P.Qualified (P.ByModuleName mn) properName <- op ^. ideTypeOpAlias = let k = getDeclarations mn & mapMaybe (preview _IdeDeclType) & filter (anyOf ideTypeName (== properName)) diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index a56231a18f..a229b601de 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -9,6 +9,7 @@ import Data.Text qualified as T import Data.Text (Text) import Language.PureScript qualified as P import Text.PrettyPrint.Boxes qualified as Box +import Data.Hashable (Hashable) -- TODO (Christoph): Text version of boxes textT :: Text -> Box.Box @@ -26,7 +27,7 @@ printModuleSignatures moduleName P.Environment{..} = moduleTypeClasses = byModuleName typeClasses moduleTypes = byModuleName types - byModuleName :: M.Map (P.Qualified a) b -> [P.Qualified a] + byModuleName :: Show a => Hashable a => M.Map (P.Qualified a) b -> [P.Qualified a] byModuleName = filter ((== Just moduleName) . P.getQual) . M.keys in @@ -58,12 +59,12 @@ printModuleSignatures moduleName P.Environment{..} = :: (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData) -> Maybe Box.Box showTypeClass (_, Nothing) = Nothing - showTypeClass (P.Qualified _ name _, Just P.TypeClassData{..}) = + showTypeClass (P.Qualified _ name, Just P.TypeClassData{..}) = let constraints = if null typeClassSuperclasses then Box.text "" else Box.text "(" - Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn _) _ lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map (P.typeAtomAsBox maxBound) lt)) typeClassSuperclasses) + Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Constraint _ (P.Qualified _ pn) _ lt _) -> textT (P.runProperName pn) Box.<+> Box.hcat Box.left (map (P.typeAtomAsBox maxBound) lt)) typeClassSuperclasses) Box.<> Box.text ") <= " className = textT (P.runProperName name) @@ -92,7 +93,7 @@ printModuleSignatures moduleName P.Environment{..} = -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.SourceType)], P.SourceType) -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceType, P.TypeKind)) -> Maybe Box.Box - showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name _), typ) = + showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = case (typ, M.lookup n typeSynonymsEnv) of (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> if M.member (fmap P.coerceProperName n) typeClassesEnv diff --git a/src/Language/PureScript/Interner.hs b/src/Language/PureScript/Interner.hs index 2f93f9a1b4..5c0170eed2 100644 --- a/src/Language/PureScript/Interner.hs +++ b/src/Language/PureScript/Interner.hs @@ -27,7 +27,7 @@ import System.Random (randomIO) -- | The opaque interned identifier newtype Interned = Interned Int - deriving (Eq, Ord, NFData) + deriving (Eq, NFData) instance Hashable Interned where hashWithSalt salt (Interned i) = hashWithSalt salt i @@ -49,7 +49,7 @@ data Interner k = Interner , reverseMap :: !(IM.IntMap k) , internerId :: Int } - deriving (Eq, Ord, Show) + deriving (Eq, Show) type InternerVar k = MVar (Interner k) diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs index ff6e3f9be8..31be35656b 100644 --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -17,7 +17,7 @@ import Language.PureScript.AST import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage') import Language.PureScript.Linter.Exhaustive as L import Language.PureScript.Linter.Imports as L -import Language.PureScript.Names (Ident(..), Qualified(..), QualifiedBy(..), getIdentName, runIdent) +import Language.PureScript.Names (Ident(..), pattern Qualified, QualifiedBy(..), getIdentName, runIdent) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), everythingWithContextOnTypes) import Language.PureScript.Constants.Libs qualified as C @@ -183,13 +183,13 @@ lintUnused (Module modSS _ mn modDecls exports) = in (vars, errs') - goDecl (ValueFixityDeclaration _ _ (Qualified _ (Left v) _) _) = (S.singleton v, mempty) + goDecl (ValueFixityDeclaration _ _ (Qualified _ (Left v)) _) = (S.singleton v, mempty) goDecl (TypeInstanceDeclaration _ _ _ _ _ _ _ _ (ExplicitInstance decls)) = mconcat $ map goDecl decls goDecl _ = mempty go :: Expr -> (S.Set Ident, MultipleErrors) - go (Var _ (Qualified (BySourcePos _) v _)) = (S.singleton v, mempty) + go (Var _ (Qualified (BySourcePos _) v)) = (S.singleton v, mempty) go (Var _ _) = (S.empty, mempty) go (Let _ ds e) = onDecls ds (go e) diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 70d049ac6c..08bd655a03 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -28,6 +28,7 @@ import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportRecord(..), Imports(..), envModuleExports, nullImports) import Language.PureScript.Sugar.Names.Imports (ImportDef, findImports) import Language.PureScript.Constants.Prim qualified as C +import Data.Hashable (Hashable) -- | -- Map of module name to list of imported names from that module which have @@ -183,20 +184,22 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do go (q, name) = M.alter (Just . maybe [name] (name :)) q extractByQual - :: ModuleName + :: Hashable a + => Show a + => ModuleName -> M.Map (Qualified a) [ImportRecord a] -> (a -> Name) -> [(ModuleName, Qualified Name)] extractByQual k m toName = mapMaybe go (M.toList m) where - go (q@(Qualified mnq _ _), is) + go (q@(Qualified mnq _), is) | isUnqualified q = case find (isQualifiedWith k) (map importName is) of - Just (Qualified _ name _) -> Just (k, mkQualified_ mnq (toName name)) + Just (Qualified _ name) -> Just (k, mkQualified_ mnq (toName name)) _ -> Nothing | isQualifiedWith k q = case importName (head is) of - Qualified (ByModuleName mn') name _ -> Just (mn', mkQualified_ mnq (toName name)) + Qualified (ByModuleName mn') name -> Just (mn', mkQualified_ mnq (toName name)) _ -> internalError "unqualified name in extractByQual" go _ = Nothing diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 899e31f864..91b48339ab 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -36,7 +36,9 @@ data Ref | ValueOpRef (P.OpName 'P.ValueOpName) | -- Instance ref points to the class and types defined in the same module. TypeInstanceRef P.Ident (ModuleName, P.ProperName 'P.ClassName) [P.ProperName 'P.TypeName] - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Generic) + +instance Hashable Ref data RefStatus = Removed | Updated deriving (Show) @@ -372,12 +374,12 @@ splitRefs new old toRef = typeDeps :: P.Type a -> S.Set (ModuleName, Ref) typeDeps = P.everythingOnTypes (<>) $ \case - P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn _) + P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn) | isPrimModule mn -> mempty | otherwise -> S.singleton (mn, TypeRef tn) P.TypeConstructor _ _ -> internalError "typeDeps: type is not qualified" - P.TypeOp _ (P.Qualified (P.ByModuleName mn) tn _) + P.TypeOp _ (P.Qualified (P.ByModuleName mn) tn) | isPrimModule mn -> mempty | otherwise -> S.singleton (mn, TypeOpRef tn) P.ConstrainedType _ c _ -> @@ -386,8 +388,8 @@ typeDeps = P.everythingOnTypes (<>) $ internalError "typeDeps: type is not qualified" _ -> mempty -qualified :: P.Qualified b -> (ModuleName, b) -qualified (P.Qualified (P.ByModuleName mn) v _) = (mn, v) +qualified :: (Show b, Hashable b) => P.Qualified b -> (ModuleName, b) +qualified (P.Qualified (P.ByModuleName mn) v) = (mn, v) qualified _ = internalError "ExternsDiff: type is not qualified" -- | To get fixity's data constructor dependency we should provide it with the @@ -451,7 +453,7 @@ externsDeclarationToRef moduleName = \case typeKindDeps (P.DataType _ args _) = foldMap goDataTypeArg args typeKindDeps _ = mempty - myType (P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn _)) + myType (P.TypeConstructor _ (P.Qualified (P.ByModuleName mn) tn)) | isPrimModule mn || moduleName /= mn = Nothing | otherwise = Just tn myType _ = Nothing diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 7c4c27e08e..055f8fa9ee 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -4,7 +4,7 @@ -- | -- Data types for names -- -module Language.PureScript.Names where +module Language.PureScript.Names (Name (..), getIdentName, getValOpName, getTypeName, getQual, disqualify, ModuleName (..), ProperName (..), runProperName, properNameFromString, OpName (..), ProperNameType (..), OpNameType (..), Qualified, mkQualified_, pattern Qualified, moduleNameFromString, InternalIdentData (..), Ident (..), coerceOpName, coerceProperName, QualifiedBy (..), runModuleName, unusedIdent, runIdent, toMaybeModuleName, pattern ByNullSourcePos, freshIdent, isQualifiedWith, isQualified, isBySourcePos, isPlainIdent, showIdent, byMaybeModuleName, disqualifyFor, getTypeOpName, getDctorName, getClassName, freshIdent', showOp, eraseOpName, isBuiltinModuleName, showQualified, qualify, mkQualified, isUnqualified) where import Prelude @@ -21,10 +21,10 @@ import Data.Aeson.TH (deriveJSON) import Data.Text (Text) import Data.Text qualified as T import Data.Int (Int64) - import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) import Language.PureScript.Interner (Interned, uninternText, internText) -import Data.Hashable (Hashable (..)) +import Data.Hashable (Hashable (hashWithSalt)) +import Debug.Trace (trace, traceStack) -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -161,8 +161,10 @@ coerceOpName = OpName . runOpName -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- newtype ProperName (a :: ProperNameType) = ProperName { unProperName :: Interned } - deriving (Eq, Ord, Generic) - deriving newtype (NFData, Hashable) + deriving (Eq, Generic) + deriving newtype (NFData) + +instance Hashable (ProperName a) properNameFromString :: Text -> ProperName a properNameFromString = ProperName . internText @@ -171,12 +173,15 @@ runProperName :: ProperName a -> Text runProperName (ProperName n) = uninternText n instance Show (ProperName a) where - show (ProperName i) = "" + show (ProperName i) = T.unpack $ uninternText i -- "" instance Serialise (ProperName a) where encode (ProperName n) = encode (uninternText n) decode = ProperName . internText <$> decode +instance Ord (ProperName a) where + compare (ProperName a) (ProperName b) = compare (uninternText a) (uninternText b) + instance ToJSON (ProperName a) where toJSON = toJSON . runProperName @@ -198,15 +203,21 @@ data ProperNameType -- classes have been desugared. -- coerceProperName :: ProperName a -> ProperName b -coerceProperName = ProperName . unProperName +coerceProperName = properNameFromString . runProperName -- | -- Module names -- newtype ModuleName = ModuleName Interned - deriving (Show, Eq, Ord, Generic) + deriving (Eq, Generic) deriving newtype (Hashable) +instance Show ModuleName where + show (ModuleName i) = T.unpack $ uninternText i + +instance Ord ModuleName where + compare (ModuleName a) (ModuleName b) = compare (uninternText a) (uninternText b) + instance Serialise ModuleName where encode (ModuleName i) = encode (uninternText i) decode = ModuleName . internText <$> decode @@ -250,99 +261,131 @@ toMaybeModuleName (BySourcePos _) = Nothing -- A qualified name, i.e. a name with an optional module name -- data Qualified a = Qualified' QualifiedBy a Int - deriving (Functor, Foldable, Traversable, Generic) + deriving (Functor, Foldable, Traversable, Generic, Show) +{-# COMPLETE Qualified #-} +pattern Qualified :: (Show a, Hashable a) => QualifiedBy -> a -> Qualified a pattern Qualified qb a <- Qualified' qb a _ where Qualified qb a = mkQualified_ qb a -instance Show a => Show (Qualified a) where - show (Qualified qb a) = case qb of - BySourcePos _ -> show a - ByModuleName mn -> T.unpack (runModuleName mn) <> "." <> show a +-- instance Show a => Show (Qualified a) where +-- show (Qualified' qb a _) = case qb of +-- BySourcePos _ -> show a +-- ByModuleName mn -> T.unpack (runModuleName mn) <> "." <> show a instance NFData a => NFData (Qualified a) +-- instance Serialise a => Serialise (Qualified a) -instance (Serialise a, Hashable a) => Serialise (Qualified a) where - encode (Qualified qb a) = encode $ Qualified' qb a +instance (Show a, Serialise a, Hashable a) => Serialise (Qualified a) where + encode (Qualified' qb a _) = encode $ QualifiedS qb a decode = do - Qualified qb a <- decode + QualifiedS qb a <- decode pure $ mkQualified_ qb a -instance Eq a => Eq (Qualified a) where - (Qualified q a _) == (Qualified q' a' _) = (q == q' && a == a') +data QualifiedS a = QualifiedS QualifiedBy a + deriving (Generic) + +instance Serialise a => Serialise (QualifiedS a) +instance NFData a => NFData (QualifiedS a) + +-- +-- instance Ord a => Ord (Qualified a) where +-- compare (Qualified' qb a1 _) (Qualified' qb' a2 _) = case compare qb qb' of +-- EQ -> compare a1 a2 +-- other -> other + +instance Hashable a => Hashable (Qualified a) where + hashWithSalt s (Qualified' _ _ h) = hashWithSalt s h + +-- instance Eq a => Eq (Qualified a) where +-- (Qualified' q a _) == (Qualified' q' a' _) = (q == q' && a == a') + +instance (Eq a) => Eq (Qualified a) where + (Qualified' q a h1) == (Qualified' q' a' h2) = + -- if q == q' && a == a' && h1 /= h2 then error "Hash mismatch when comparing" + (h1 == h2) || (q == q' && a == a') +-- instance Ord a => Ord (Qualified a) where - compare (Qualified qb a1 _) (Qualified qb' a2 _) = case compare qb qb' of + compare (Qualified' qb a1 _) (Qualified' qb' a2 _) = case compare qb qb' of EQ -> compare a1 a2 other -> other -instance Hashable a => Hashable (Qualified a) where - hashWithSalt s (Qualified _ _ h) = hashWithSalt s h -showQualified :: (a -> Text) -> Qualified a -> Text -showQualified f (Qualified (BySourcePos _) a _) = f a -showQualified f (Qualified (ByModuleName name) a _) = runModuleName name <> "." <> f a +showQualified :: (Show a, Hashable a) => (a -> Text) -> Qualified a -> Text +showQualified f (Qualified (BySourcePos _) a) = f a +showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a -getQual :: Qualified a -> Maybe ModuleName -getQual (Qualified qb _ _) = toMaybeModuleName qb +getQual :: (Show a, Hashable a) => Qualified a -> Maybe ModuleName +getQual (Qualified qb _) = toMaybeModuleName qb -- | -- Provide a default module name, if a name is unqualified -- -qualify :: ModuleName -> Qualified a -> (ModuleName, a) -qualify m (Qualified (BySourcePos _) a _) = (m, a) -qualify _ (Qualified (ByModuleName m) a _) = (m, a) +qualify :: (Show a, Hashable a) => ModuleName -> Qualified a -> (ModuleName, a) +qualify m (Qualified (BySourcePos _) a) = (m, a) +qualify _ (Qualified (ByModuleName m) a) = (m, a) -- | -- Makes a qualified value from a name and module name. -- -mkQualified :: Hashable a => a -> ModuleName -> Qualified a -mkQualified name mn = Qualified (ByModuleName mn) name (hashWithSalt 1 mn `hashWithSalt` name) - -mkQualified_ :: Hashable a => QualifiedBy -> a -> Qualified a -mkQualified_ qb name = Qualified qb name (hashWithSalt 1 qb `hashWithSalt` name) +mkQualified :: (Show a, Hashable a) => a -> ModuleName -> Qualified a +mkQualified name mn = + let + qb = ByModuleName mn + h = (hashWithSalt 1 qb `hashWithSalt` name) + -- in if h == -8933003785015192445 || h == 126158207429918995 + -- then traceStack ("mkQualified: " <> show qb <> " " <> show name <> " h:" <> show h) $ Qualified' qb name h + in Qualified' qb name h + +mkQualified_ :: (Show a, Hashable a) => QualifiedBy -> a -> Qualified a +mkQualified_ qb name = + let h = (hashWithSalt 1 qb `hashWithSalt` name) + -- in if h == -8933003785015192445 || h == 126158207429918995 + -- then traceStack ("mkQualified: " <> show qb <> " " <> show name <> " h:" <> show h) $ Qualified' qb name h + in Qualified' qb name h -- | Remove the module name from a qualified name -disqualify :: Qualified a -> a -disqualify (Qualified _ a _) = a +disqualify :: (Show a, Hashable a) => Qualified a -> a +disqualify (Qualified _ a) = a -- | -- Remove the qualification from a value when it is qualified with a particular -- module name. -- -disqualifyFor :: Maybe ModuleName -> Qualified a -> Maybe a -disqualifyFor mn (Qualified qb a _) | mn == toMaybeModuleName qb = Just a +disqualifyFor :: (Show a, Hashable a) => Maybe ModuleName -> Qualified a -> Maybe a +disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a disqualifyFor _ _ = Nothing -- | -- Checks whether a qualified value is actually qualified with a module reference -- -isQualified :: Qualified a -> Bool -isQualified (Qualified (BySourcePos _) _ _) = False +isQualified :: (Show a, Hashable a) => Qualified a -> Bool +isQualified (Qualified (BySourcePos _) _) = False isQualified _ = True -- | -- Checks whether a qualified value is not actually qualified with a module reference -- -isUnqualified :: Qualified a -> Bool +isUnqualified :: (Show a, Hashable a) => Qualified a -> Bool isUnqualified = not . isQualified -- | -- Checks whether a qualified value is qualified with a particular module -- -isQualifiedWith :: ModuleName -> Qualified a -> Bool -isQualifiedWith mn (Qualified (ByModuleName mn') _ _) = mn == mn' +isQualifiedWith :: (Show a, Hashable a) => ModuleName -> Qualified a -> Bool +isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn' isQualifiedWith _ _ = False -instance ToJSON a => ToJSON (Qualified a) where - toJSON (Qualified qb a _) = case qb of +instance (Show a, Hashable a, ToJSON a) => ToJSON (Qualified a) where + toJSON (Qualified qb a) = case qb of ByModuleName mn -> toJSON2 (mn, a) BySourcePos ss -> toJSON2 (ss, a) -instance (FromJSON a, Hashable a) => FromJSON (Qualified a) where +instance (Show a, FromJSON a, Hashable a) => FromJSON (Qualified a) where parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName' where byModule = do diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index abc3e5246c..961e70daf2 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -52,9 +52,12 @@ import Language.PureScript.Interner (Interned, uninternPSString, internPSString) -- and arrays of UTF-16 code units (integers) otherwise. -- newtype PSString = PSString { unPSString :: Interned } - deriving (Eq, Ord, NFData, Generic) + deriving (Eq, NFData, Generic) deriving newtype Hashable +instance Ord PSString where + compare (PSString a) (PSString b) = compare (uninternPSString a) (uninternPSString b) + instance Show PSString where show = show . codePoints diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 7e614ee265..50c66c722c 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -18,7 +18,7 @@ import Data.Text qualified as T import Language.PureScript.AST (AssocList(..), Binder(..), CaseAlternative(..), Declaration(..), DoNotationElement(..), Expr(..), Guard(..), GuardedExpr(..), Literal(..), PathNode(..), PathTree(..), TypeDeclarationData(..), pattern ValueDecl, WhereProvenance(..)) import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (OpName(..), Qualified(..), disqualify, runModuleName, showIdent, runProperName) +import Language.PureScript.Names (OpName(..), pattern Qualified, disqualify, runModuleName, showIdent, runProperName) import Language.PureScript.Pretty.Common (before, beforeWithSpace, parensT) import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox, prettyPrintObjectKey) import Language.PureScript.Types (Constraint(..)) @@ -110,7 +110,7 @@ prettyPrintValueAtom _ (Var _ ident) = text $ T.unpack $ showIdent (disqualify i prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where - printOp (Op _ (Qualified _ name _)) = text $ T.unpack $ runOpName name + printOp (Op _ (Qualified _ name)) = text $ T.unpack $ runOpName name printOp expr = text "`" <> prettyPrintValue (d - 1) expr `before` text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val diff --git a/src/Language/PureScript/Renamer.hs b/src/Language/PureScript/Renamer.hs index f1a6f8317d..0827657002 100644 --- a/src/Language/PureScript/Renamer.hs +++ b/src/Language/PureScript/Renamer.hs @@ -16,7 +16,7 @@ import Data.Set qualified as S import Data.Text qualified as T import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), Expr(..), Literal(..), Module(..)) -import Language.PureScript.Names (Ident(..), Qualified(..), isBySourcePos, isPlainIdent, runIdent, showIdent, mkQualified_) +import Language.PureScript.Names (Ident(..), pattern Qualified, isBySourcePos, isPlainIdent, runIdent, showIdent, mkQualified_) import Language.PureScript.Traversals (eitherM, pairM, sndM) -- | @@ -173,7 +173,7 @@ renameInValue (Abs ann name v) = newScope $ Abs ann <$> updateScope name <*> renameInValue v renameInValue (App ann v1 v2) = App ann <$> renameInValue v1 <*> renameInValue v2 -renameInValue (Var ann (Qualified qb name _)) | isBySourcePos qb || not (isPlainIdent name) = +renameInValue (Var ann (Qualified qb name)) | isBySourcePos qb || not (isPlainIdent name) = -- This should only rename identifiers local to the current module: either -- they aren't qualified, or they are but they have a name that should not -- have appeared in a module's externs, so they must be from this module's diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index fef9709ee9..574ec083f5 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -28,7 +28,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (NameKind) import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..), errorMessage', parU, positionedError) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, ModuleName, ProperName, ProperNameType(..), pattern Qualified, QualifiedBy(..), coerceProperName, mkQualified_) import Language.PureScript.Types (Constraint(..), SourceConstraint, SourceType, Type(..), everythingOnTypes) data VertexType @@ -172,9 +172,9 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . valdeclExpression (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def usedNamesE :: S.Set ScopedIdent -> Expr -> [Ident] - usedNamesE scope (Var _ (Qualified (BySourcePos _) name _)) + usedNamesE scope (Var _ (Qualified (BySourcePos _) name)) | LocalIdent name `S.notMember` scope = [name] - usedNamesE scope (Var _ (Qualified (ByModuleName moduleName') name _)) + usedNamesE scope (Var _ (Qualified (ByModuleName moduleName') name)) | moduleName == moduleName' && ToplevelIdent name `S.notMember` scope = [name] usedNamesE _ _ = [] @@ -186,8 +186,8 @@ usedImmediateIdents moduleName = def s _ = (s, []) usedNamesE :: Bool -> Expr -> (Bool, [Ident]) - usedNamesE True (Var _ (Qualified (BySourcePos _) name _)) = (True, [name]) - usedNamesE True (Var _ (Qualified (ByModuleName moduleName') name _)) + usedNamesE True (Var _ (Qualified (BySourcePos _) name)) = (True, [name]) + usedNamesE True (Var _ (Qualified (ByModuleName moduleName') name)) | moduleName == moduleName' = (True, [name]) usedNamesE True (Abs _ _) = (False, []) usedNamesE scope _ = (scope, []) @@ -202,12 +202,12 @@ usedTypeNames moduleName = go usedNames :: SourceType -> [ProperName 'TypeName] usedNames (ConstrainedType _ con _) = usedConstraint con - usedNames (TypeConstructor _ (Qualified (ByModuleName moduleName') name _)) + usedNames (TypeConstructor _ (Qualified (ByModuleName moduleName') name)) | moduleName == moduleName' = [name] usedNames _ = [] usedConstraint :: SourceConstraint -> [ProperName 'TypeName] - usedConstraint (Constraint _ (Qualified (ByModuleName moduleName') name _) _ _ _) + usedConstraint (Constraint _ (Qualified (ByModuleName moduleName') name) _ _ _) | moduleName == moduleName' = [coerceProperName name] usedConstraint _ = [] diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index a7844cfe6d..545c6b0938 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -28,7 +28,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage'', nonEmpty, parU, warnAndRethrow, warnAndRethrowWithPosition) import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..), ExternsImport(..)) import Language.PureScript.Linter.Imports (Name(..), UsedImports) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), mkQualified_) import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), checkImportConflicts, nullImports, primEnv) import Language.PureScript.Sugar.Names.Exports (findExportable, resolveExports) import Language.PureScript.Sugar.Names.Imports (resolveImports, resolveModuleImport) @@ -233,12 +233,12 @@ renameInModule imports (Module modSS coms mn decls exps) = TypeFixityDeclaration sa fixity <$> updateTypeName alias ss <*> pure op - updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Left alias) _) op) = + updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Left alias)) op) = fmap (bound,) $ ValueFixityDeclaration sa fixity . fmap Left <$> updateValueName (mkQualified_ mn' alias) ss <*> pure op - updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Right alias) _) op) = + updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Right alias)) op) = fmap (bound,) $ ValueFixityDeclaration sa fixity . fmap Right <$> updateDataConstructorName (mkQualified_ mn' alias) ss @@ -265,7 +265,7 @@ renameInModule imports (Module modSS coms mn decls exps) = when (nonEmpty duplicateArgsErrs) $ throwError duplicateArgsErrs return ((pos, declarationsToMap ds `M.union` bound), Let w ds val') - updateValue (_, bound) (Var ss name'@(Qualified qualifiedBy ident _)) = + updateValue (_, bound) (Var ss name'@(Qualified qualifiedBy ident)) = ((ss, bound), ) <$> case (M.lookup ident bound, qualifiedBy) of -- bound idents that have yet to be locally qualified. (Just sourcePos, ByNullSourcePos) -> @@ -407,13 +407,13 @@ renameInModule imports (Module modSS coms mn decls exps) = -- qualified references are replaced with their canonical qualified names -- (e.g. M.Map -> Data.Map.Map). update - :: (Ord a, Hashable a) + :: (Ord a, Hashable a, Show a) => M.Map (Qualified a) [ImportRecord a] -> (a -> Name) -> Qualified a -> SourceSpan -> m (Qualified a) - update imps toName qname@(Qualified mn' name _) pos = warnAndRethrowWithPosition pos $ + update imps toName qname@(Qualified mn' name) pos = warnAndRethrowWithPosition pos $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index c07483fc9c..346ba29a45 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -37,7 +37,8 @@ import Language.PureScript.AST (ExportSource(..), SourceSpan, internalModuleSour import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') -import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual, mkQualified_) +import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual, mkQualified_) +import Data.Hashable (Hashable) -- | -- The details for an import: the name of the thing that is being imported @@ -229,11 +230,11 @@ mkPrimExports ts cs = , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys cs } where - mkTypeEntry (Qualified (ByModuleName mn) name _) = (name, ([], primExportSource mn)) + mkTypeEntry (Qualified (ByModuleName mn) name) = (name, ([], primExportSource mn)) mkTypeEntry _ = internalError "mkPrimExports.mkTypeEntry: a name is qualified BySourcePos instead of ByModuleName" - mkClassEntry (Qualified (ByModuleName mn) name _) = (name, primExportSource mn) + mkClassEntry (Qualified (ByModuleName mn) name) = (name, primExportSource mn) mkClassEntry _ = internalError "mkPrimExports.mkClassEntry: a name is qualified BySourcePos instead of ByModuleName" @@ -471,7 +472,7 @@ throwExportConflict' ss new existing newName existingName = -- checkImportConflicts :: forall m a - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (Hashable a, Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => SourceSpan -> ModuleName -> (a -> Name) @@ -487,7 +488,7 @@ checkImportConflicts ss currentModule toName xs = in if length groups > 1 then case nonImplicit of - [ImportRecord (Qualified (ByModuleName mnNew) _ _) mnOrig _ _] -> do + [ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _] -> do let warningModule = if mnNew == currentModule then Nothing else Just mnNew ss' = maybe nullSourceSpan importSourceSpan . headMay . filter ((== FromImplicit) . importProvenance) $ xs tell . errorMessage' ss' $ ScopeShadowing name warningModule $ delete mnNew conflictModules @@ -495,7 +496,7 @@ checkImportConflicts ss currentModule toName xs = _ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules else case head byOrig of - ImportRecord (Qualified (ByModuleName mnNew) _ _) mnOrig _ _ -> + ImportRecord (Qualified (ByModuleName mnNew) _) mnOrig _ _ -> return (mnNew, mnOrig) _ -> internalError "checkImportConflicts: ImportRecord should be qualified" diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index c7fa732d70..48f613a167 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -18,9 +18,10 @@ import Data.Map qualified as M import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow, rethrowWithPosition, warnAndRethrow) -import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), disqualifyFor, isQualifiedWith, isUnqualified) +import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), disqualifyFor, isQualifiedWith, isUnqualified) import Language.PureScript.Sugar.Names.Env (Env, ExportMode(..), Exports(..), ImportRecord(..), Imports(..), checkImportConflicts, envModuleExports, exportType, exportTypeClass, exportTypeOp, exportValue, exportValueOp, nullExports) import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) +import Data.Hashable (Hashable) -- | -- Finds all exportable members of a module, disregarding any explicit exports. @@ -121,7 +122,9 @@ resolveExports env ss mn imps exps refs = -- Extracts a list of values for a module based on a lookup table. If the -- boolean is true the values are filtered by the qualification extract - :: SourceSpan + :: Hashable a + => Show a + => SourceSpan -> Bool -> ModuleName -> (a -> Name) @@ -170,7 +173,7 @@ resolveExports env ss mn imps exps refs = go :: Qualified (ProperName 'TypeName) -> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ExportSource) - go (Qualified (ByModuleName mn'') name _) = + go (Qualified (ByModuleName mn'') name) = fromMaybe (internalError "Missing value in resolveTypeExports") $ do exps' <- envModuleExports <$> mn'' `M.lookup` env (dctors', src) <- name `M.lookup` exportedTypes exps' @@ -179,7 +182,7 @@ resolveExports env ss mn imps exps refs = ( (name, relevantDctors `intersect` dctors') , src { exportSourceImportedFrom = Just mn'' } ) - go (Qualified _ _ _) = internalError "Unqualified value in resolveTypeExports" + go (Qualified _ _) = internalError "Unqualified value in resolveTypeExports" -- Looks up an imported type operator and re-qualifies it with the original -- module it came from. @@ -210,11 +213,11 @@ resolveExports env ss mn imps exps refs = $ resolve exportedValueOps op resolve - :: Ord a + :: (Ord a, Hashable a, Show a) => (Exports -> M.Map a ExportSource) -> Qualified a -> Maybe (a, ExportSource) - resolve f (Qualified (ByModuleName mn'') a _) = do + resolve f (Qualified (ByModuleName mn'') a) = do exps' <- envModuleExports <$> mn'' `M.lookup` env src <- a `M.lookup` f exps' return (a, src { exportSourceImportedFrom = Just mn'' }) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index a1a57b5d24..b048769f93 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -18,7 +18,7 @@ import Data.Set qualified as S import Language.PureScript.AST (Declaration(..), DeclarationRef(..), ErrorMessageHint(..), ExportSource(..), ImportDeclarationType(..), Module(..), SourceSpan, internalModuleSourceSpan) import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow) -import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName, ProperNameType(..), QualifiedBy(..), byMaybeModuleName, mkQualified_, Qualified) import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), envModuleExports, nullImports) import Data.Hashable (Hashable) @@ -211,7 +211,7 @@ resolveImport importModule exps imps impQual = resolveByType -- Add something to an import resolution list updateImports - :: (Ord a, Hashable a) + :: (Ord a, Hashable a, Show a) => M.Map (Qualified a) [ImportRecord a] -> M.Map a b -> (b -> ExportSource) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index c0b8963ebd..e4b650f3b4 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -19,7 +19,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition) import Language.PureScript.Externs (ExternsFile(..), ExternsFixity(..), ExternsTypeFixity(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent', mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), freshIdent', mkQualified_) import Language.PureScript.Sugar.Operators.Binders (matchBinderOperators) import Language.PureScript.Sugar.Operators.Expr (matchExprOperators) import Language.PureScript.Sugar.Operators.Types (matchTypeOperators) @@ -39,6 +39,7 @@ import Data.List (groupBy, sortOn) import Data.Maybe (mapMaybe, listToMaybe) import Data.Map qualified as M import Data.Ord (Down(..)) +import Data.Hashable (Hashable) import Language.PureScript.Constants.Libs qualified as C @@ -112,7 +113,7 @@ rebracketFiltered !caller pred_ externs m = do where ensureNoDuplicates' - :: Ord op + :: (Ord op, Hashable op, Show op) => (op -> SimpleErrorMessage) -> [FixityRecord op alias] -> m () @@ -150,9 +151,9 @@ rebracketFiltered !caller pred_ externs m = do goExpr _ e@(PositionedValue pos _ _) = return (pos, e) goExpr _ (Op pos op) = (pos,) <$> case op `M.lookup` valueAliased of - Just (Qualified mn' (Left alias) _) -> + Just (Qualified mn' (Left alias)) -> return $ Var pos (mkQualified_ mn' alias) - Just (Qualified mn' (Right alias) _) -> + Just (Qualified mn' (Right alias)) -> return $ Constructor pos (mkQualified_ mn' alias) Nothing -> throwError . errorMessage' pos . UnknownName $ fmap ValOpName op @@ -162,9 +163,9 @@ rebracketFiltered !caller pred_ externs m = do goBinder _ b@(PositionedBinder pos _ _) = return (pos, b) goBinder _ (BinaryNoParensBinder (OpBinder pos op) lhs rhs) = case op `M.lookup` valueAliased of - Just (Qualified mn' (Left alias) _) -> + Just (Qualified mn' (Left alias)) -> throwError . errorMessage' pos $ InvalidOperatorInBinder op (mkQualified_ mn' alias) - Just (Qualified mn' (Right alias) _) -> + Just (Qualified mn' (Right alias)) -> return (pos, ConstructorBinder pos (mkQualified_ mn' alias) [lhs, rhs]) Nothing -> throwError . errorMessage' pos . UnknownName $ fmap ValOpName op @@ -331,7 +332,7 @@ collectFixities (Module _ _ moduleName ds _) = concatMap collect ds collect _ = [] ensureNoDuplicates - :: (Ord a, MonadError MultipleErrors m) + :: (Hashable a, Ord a, Show a, MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> [(Qualified a, SourceSpan)] -> m () @@ -339,7 +340,7 @@ ensureNoDuplicates toError m = go $ sortOn fst m where go [] = return () go [_] = return () - go ((x@(Qualified (ByModuleName mn) op _), _) : (y, pos) : _) | x == y = + go ((x@(Qualified (ByModuleName mn) op), _) : (y, pos) : _) | x == y = rethrow (addHint (ErrorInModule mn)) $ rethrowWithPosition pos $ throwError . errorMessage $ toError op go (_ : rest) = go rest @@ -464,7 +465,7 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = getTypeOpAlias op = listToMaybe (mapMaybe (either (const Nothing) go <=< getFixityDecl) ds) where - go (TypeFixity _ (Qualified (ByModuleName mn') ident _) op') + go (TypeFixity _ (Qualified (ByModuleName mn') ident) op') | mn == mn' && op == op' = Just ident go _ = Nothing @@ -476,7 +477,7 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) = getValueOpAlias op = listToMaybe (mapMaybe (either go (const Nothing) <=< getFixityDecl) ds) where - go (ValueFixity _ (Qualified (ByModuleName mn') ident _) op') + go (ValueFixity _ (Qualified (ByModuleName mn') ident) op') | mn == mn' && op == op' = Just ident go _ = Nothing diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index 622ad99e38..62d1d78b68 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -6,7 +6,7 @@ import Control.Monad.Except (MonadError) import Language.PureScript.AST (Associativity, Binder(..), SourceSpan) import Language.PureScript.Errors (MultipleErrors) -import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) +import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified(..)) import Language.PureScript.Sugar.Operators.Common (matchOperators) matchBinderOperators @@ -26,7 +26,7 @@ matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id extractOp _ = Nothing fromOp :: Binder -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName)) - fromOp (OpBinder ss q@(Qualified _ (OpName _) _)) = Just (ss, q) + fromOp (OpBinder ss q@(Qualified _ (OpName _))) = Just (ss, q) fromOp _ = Nothing reapply :: SourceSpan -> Qualified (OpName 'ValueOpName) -> Binder -> Binder -> Binder diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index 1a04896691..f21056162b 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -9,7 +9,7 @@ import Text.Parsec qualified as P import Text.Parsec.Expr qualified as P import Language.PureScript.AST (Associativity, Expr(..), SourceSpan) -import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) +import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified(..)) import Language.PureScript.Sugar.Operators.Common (Chain, matchOperators, token) import Language.PureScript.Errors (MultipleErrors) @@ -32,7 +32,7 @@ matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable extractOp _ = Nothing fromOp :: Expr -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName)) - fromOp (Op ss q@(Qualified _ (OpName _) _)) = Just (ss, q) + fromOp (Op ss q@(Qualified _ (OpName _))) = Just (ss, q) fromOp _ = Nothing reapply :: SourceSpan -> Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index acb3cd8265..34dc882b90 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -5,7 +5,7 @@ import Prelude import Control.Monad.Except (MonadError) import Language.PureScript.AST (Associativity, SourceSpan) import Language.PureScript.Errors (MultipleErrors) -import Language.PureScript.Names (OpName(..), OpNameType(..), Qualified(..)) +import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified(..)) import Language.PureScript.Sugar.Operators.Common (matchOperators) import Language.PureScript.Types (SourceType, Type(..), srcTypeApp) @@ -27,7 +27,7 @@ matchTypeOperators ss = matchOperators isBinOp extractOp fromOp reapply id extractOp _ = Nothing fromOp :: SourceType -> Maybe (SourceSpan, Qualified (OpName 'TypeOpName)) - fromOp (TypeOp _ q@(Qualified _ (OpName _) _)) = Just (ss, q) + fromOp (TypeOp _ q@(Qualified _ (OpName _))) = Just (ss, q) fromOp _ = Nothing reapply :: a -> Qualified (OpName 'TypeOpName) -> SourceType -> SourceType -> SourceType diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 54d86e68ab..34ed09408b 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -30,7 +30,7 @@ import Language.PureScript.Environment (DataDeclType(..), NameKind(..), TypeClas import Language.PureScript.Errors hiding (isExported, nonEmpty) import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent, mkQualified_) import Language.PureScript.PSString (mkString) import Language.PureScript.Sugar.CaseDeclarations (desugarCases) import Language.PureScript.TypeClassDictionaries (superclassName) @@ -250,7 +250,7 @@ desugarDecl mn exps = go :: (ProperName a -> [DeclarationRef] -> Bool) -> Qualified (ProperName a) -> Bool - isExported test (Qualified (ByModuleName mn') pn _) = mn /= mn' || test pn exps + isExported test (Qualified (ByModuleName mn') pn) = mn /= mn' || test pn exps isExported _ _ = internalError "Names should have been qualified in name desugaring" matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 324cdfc064..eb56d2b559 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -35,7 +35,7 @@ import Language.PureScript.Environment (DataDeclType(..), Environment(..), Funct import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, errorMessage', positionedError, rethrow, warnAndRethrow, MultipleErrors) import Language.PureScript.Linter (checkExhaustiveExpr) import Language.PureScript.Linter.Wildcards (ignoreWildcardsUnderCompleteTypeSignatures) -import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified, mkQualified_) +import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified, mkQualified_) import Language.PureScript.Roles (Role) import Language.PureScript.Sugar.Names.Env (Exports(..)) import Language.PureScript.TypeChecker.Kinds as T @@ -430,7 +430,7 @@ typeCheckAll moduleName = traverse go -> TypeClassData -> [SourceType] -> S.Set ModuleName - findNonOrphanModules (Qualified (ByModuleName mn') _ _) typeClass tys' = nonOrphanModules + findNonOrphanModules (Qualified (ByModuleName mn') _) typeClass tys' = nonOrphanModules where nonOrphanModules :: S.Set ModuleName nonOrphanModules = S.insert mn' nonOrphanModules' @@ -439,8 +439,8 @@ typeCheckAll moduleName = traverse go typeModule (TypeVar _ _) = Nothing typeModule (TypeLevelString _ _) = Nothing typeModule (TypeLevelInt _ _) = Nothing - typeModule (TypeConstructor _ (Qualified (ByModuleName mn'') _ _)) = Just mn'' - typeModule (TypeConstructor _ (Qualified (BySourcePos _) _ _)) = internalError "Unqualified type name in findNonOrphanModules" + typeModule (TypeConstructor _ (Qualified (ByModuleName mn'') _)) = Just mn'' + typeModule (TypeConstructor _ (Qualified (BySourcePos _) _)) = internalError "Unqualified type name in findNonOrphanModules" typeModule (TypeApp _ t1 _) = typeModule t1 typeModule (KindApp _ t1 _) = typeModule t1 typeModule (KindedType _ t1 _) = typeModule t1 @@ -482,7 +482,7 @@ typeCheckAll moduleName = traverse go for_ nonOrphanModules $ \m -> do dicts <- HM.toList <$> lookupTypeClassDictionariesForClass (ByModuleName m) className - for_ dicts $ \(Qualified mn' ident _, dictNel) -> do + for_ dicts $ \(Qualified mn' ident, dictNel) -> do for_ dictNel $ \dict -> do -- ignore instances in the same instance chain if ch == tcdChain dict || @@ -609,14 +609,14 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = toImportDecl (sa, moduleName, importDeclarationType, asModuleName, _) = ImportDeclaration sa moduleName importDeclarationType asModuleName - qualify' :: Hashable a => a -> Qualified a + qualify' :: Show a => Hashable a => a -> Qualified a qualify' = mkQualified_ (ByModuleName mn) getSuperClassExportCheck = do classesToSuperClasses <- gets ( M.map ( S.fromList - . filter (\(Qualified mn' _ _) -> mn' == ByModuleName mn) + . filter (\(Qualified mn' _) -> mn' == ByModuleName mn) . fmap constraintClass . typeClassSuperclasses ) @@ -712,7 +712,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = findTcons :: SourceType -> [DeclarationRef] findTcons = everythingOnTypes (++) go where - go (TypeConstructor _ (Qualified (ByModuleName mn') name _)) | mn' == mn = + go (TypeConstructor _ (Qualified (ByModuleName mn') name)) | mn' == mn = [TypeRef (declRefSourceSpan ref) name (internalError "Data constructors unused in checkTypesAreExported")] go _ = [] @@ -727,7 +727,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = go (ConstrainedType _ c _) = (fmap (TypeClassRef (declRefSourceSpan ref)) . extractCurrentModuleClass . constraintClass) c go _ = [] extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName] - extractCurrentModuleClass (Qualified (ByModuleName mn') name _) | mn == mn' = [name] + extractCurrentModuleClass (Qualified (ByModuleName mn') name) | mn == mn' = [name] extractCurrentModuleClass _ = [] checkClassMembersAreExported :: DeclarationRef -> TypeCheckM () diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index b858475faf..8164c0d167 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -23,7 +23,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>)) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString, mkQualified_) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames) import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts) @@ -503,7 +503,7 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con lparamIsContra = any lparamIsContravariant contravarianceSupport hasInstance :: InstanceContext -> Qualified (Either Text (ProperName 'TypeName)) -> Qualified (ProperName 'ClassName) -> Bool - hasInstance tcds ht@(Qualified qb _ _) cn@(Qualified cqb _ _) = + hasInstance tcds ht@(Qualified qb _) cn@(Qualified cqb _) = any tcdAppliesToType $ concatMap (findDicts tcds cn) (ordNub [ByNullSourcePos, cqb, qb]) where tcdAppliesToType tcd = case tcdInstanceTypes tcd of @@ -520,7 +520,7 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con KindApp _ ty _ -> go ty TypeVar _ nm -> mkQualified_ ByNullSourcePos (Left nm) Skolem _ nm _ _ _ -> mkQualified_ ByNullSourcePos (Left nm) - TypeConstructor _ (Qualified qb nm h) -> Qualified qb (Right nm) h + TypeConstructor _ (Qualified qb nm) -> Qualified qb (Right nm) ty -> internalError $ "headOfType missing a case: " <> show (void ty) usingLamIdent :: (Expr -> TypeCheckM Expr) -> TypeCheckM Expr diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 593d3cf6de..73e646f1db 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -40,7 +40,7 @@ import Language.PureScript.AST.Declarations (UnknownsHint(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName, mkQualified_) import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds) import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation) import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') @@ -218,12 +218,12 @@ entails SolverOptions{..} constraint context hints = forClassName _ _ C.RowLacks kinds args | Just dicts <- solveLacks kinds args = dicts forClassName _ _ C.RowCons kinds args | Just dicts <- solveRowCons kinds args = dicts forClassName _ _ C.RowToList kinds args | Just dicts <- solveRowToList kinds args = dicts - forClassName _ ctx cn@(Qualified (ByModuleName mn) _ _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys))) + forClassName _ ctx cn@(Qualified (ByModuleName mn) _) _ tys = concatMap (findDicts ctx cn) (ordNub (ByNullSourcePos : ByModuleName mn : map ByModuleName (mapMaybe ctorModules tys))) forClassName _ _ _ _ _ = internalError "forClassName: expected qualified class name" ctorModules :: SourceType -> Maybe ModuleName - ctorModules (TypeConstructor _ (Qualified (ByModuleName mn) _ _)) = Just mn - ctorModules (TypeConstructor _ (Qualified (BySourcePos _) _ _)) = internalError "ctorModules: unqualified type name" + ctorModules (TypeConstructor _ (Qualified (ByModuleName mn) _)) = Just mn + ctorModules (TypeConstructor _ (Qualified (BySourcePos _) _)) = internalError "ctorModules: unqualified type name" ctorModules (TypeApp _ ty _) = ctorModules ty ctorModules (KindApp _ ty _) = ctorModules ty ctorModules (KindedType _ ty _) = ctorModules ty diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 898d715617..1187099720 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -38,7 +38,7 @@ import Data.Set qualified as S import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds) import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..)) -import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), byMaybeModuleName, toMaybeModuleName, mkQualified_) +import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), pattern Qualified, Qualified(..), byMaybeModuleName, toMaybeModuleName, mkQualified_) import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds') import Language.PureScript.TypeChecker.Monad (CheckState(..), TypeCheckM) import Language.PureScript.TypeChecker.Roles (lookupRoles) @@ -672,7 +672,7 @@ lookupNewtypeConstructorInScope -> Qualified (ProperName 'TypeName) -> [SourceType] -> Maybe (Bool, Maybe ModuleName, [Text], Qualified (ProperName 'ConstructorName), SourceType) -lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName _) ks = do +lookupNewtypeConstructorInScope env currentModuleName currentModuleImports qualifiedNewtypeName@(Qualified newtypeModuleName newtypeName) ks = do let fromModule = find isNewtypeCtorImported currentModuleImports fromModuleName = (\(_, n, _, _, _) -> n) <$> fromModule asModuleName = (\(_, _, _, n, _) -> n) =<< fromModule diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 4ae4cc23e0..94f11f3e07 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -22,7 +22,7 @@ import Data.List.NonEmpty qualified as NEL import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..)) import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition) -import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString, mkQualified_) +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified, pattern Qualified, QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString, mkQualified_) import Language.PureScript.Pretty.Types (prettyPrintType) import Language.PureScript.Pretty.Values (prettyPrintValue) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) @@ -223,7 +223,7 @@ withTypeClassDictionaries entries action = do let mentries = HM.fromListWith (HM.unionWith (HM.unionWith (<>))) [ (qb, HM.singleton className (HM.singleton tcdValue (pure entry))) - | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _ _), tcdClassName = className } + | entry@TypeClassDictionaryInScope{ tcdValue = tcdValue@(Qualified qb _), tcdClassName = className } <- entries ] @@ -307,7 +307,7 @@ getVisibility qual = do checkVisibility :: Qualified Ident -> TypeCheckM () -checkVisibility name@(Qualified _ var _) = do +checkVisibility name@(Qualified _ var) = do vis <- getVisibility name case vis of Undefined -> throwError . errorMessage $ CycleInDeclaration var @@ -318,7 +318,7 @@ lookupTypeVariable :: ModuleName -> Qualified (ProperName 'TypeName) -> TypeCheckM SourceType -lookupTypeVariable currentModule (Qualified qb name _) = do +lookupTypeVariable currentModule (Qualified qb name) = do env <- getEnv case M.lookup (mkQualified_ qb' name) (types env) of Nothing -> throwError . errorMessage $ UndefinedTypeVariable name @@ -336,7 +336,7 @@ getEnv = gets checkEnv getLocalContext :: TypeCheckM Context getLocalContext = do env <- getEnv - return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{} _, (ty', _, Defined)) <- M.toList (names env) ] + return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ] -- | Update the @Environment@ putEnv :: Environment -> TypeCheckM () diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index c4b146b0d0..cfce31c954 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -26,7 +26,7 @@ import Data.Text (Text) import Language.PureScript.Environment (Environment(..), TypeKind(..)) import Language.PureScript.Errors (DataConstructorDeclaration(..), MultipleErrors, RoleDeclarationData(..), SimpleErrorMessage(..), errorMessage) -import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified(..), QualifiedBy(..), mkQualified_) +import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified, QualifiedBy(..), mkQualified_) import Language.PureScript.Roles (Role(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), freeTypeVariables, unapplyTypes) diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index c2be4cfe10..41dd95fc6b 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -126,7 +126,7 @@ typeSearch unsolved env st type' = matchingConstructors = runTypeSearch (Map.map (\(_, _, ty, _) -> ty) (P.dataConstructors env)) (allLabels, matchingLabels) = accessorSearch unsolved env st type' - runPlainIdent (Qualified m (Ident k) h, v) = Just (Qualified m k h, v) + runPlainIdent (Qualified m (Ident k), v) = Just (Qualified m k, v) runPlainIdent _ = Nothing in ( (first (P.mkQualified_ P.ByNullSourcePos . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index f1dfd34c63..5bb1864a5b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -50,7 +50,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent, properNameFromString, runProperName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified, QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent, properNameFromString, runProperName, mkQualified_) import Language.PureScript.TypeChecker.Deriving (deriveInstance) import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) @@ -781,7 +781,7 @@ check' val (ForAll ann vis ident mbK ty _) = do | otherwise = val val' <- tvToExpr <$> check skVal sk return $ TypedValue' True val' (ForAll ann vis ident mbK ty (Just scope)) -check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ className _) _ _ _) ty) = do +check' val t@(ConstrainedType _ con@(Constraint _ cls@(Qualified _ className) _ _ _) ty) = do TypeClassData{ typeClassIsEmpty } <- lookupTypeClass cls -- An empty class dictionary is never used; see code in `TypeChecker.Entailment` -- that wraps empty dictionary solutions in `Unused`. @@ -1021,7 +1021,7 @@ isInternal :: Expr -> Bool isInternal = \case PositionedValue _ _ v -> isInternal v TypedValue _ v _ -> isInternal v - Constructor _ (Qualified _ name _) -> isDictTypeName name + Constructor _ (Qualified _ name) -> isDictTypeName name DerivedInstancePlaceholder{} -> True _ -> False diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 9b6edf7a2c..c7b53b931c 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -25,10 +25,12 @@ import GHC.Generics (Generic) import Language.PureScript.AST.SourcePos (pattern NullSourceAnn, SourceAnn, SourceSpan) import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName) +import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName, showQualified) import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) -import Data.Hashable (Hashable (hashWithSalt)) +import Data.Hashable (Hashable (hashWithSalt, hash)) +import GHC.Stack (HasCallStack) +import Debug.Trace (trace) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn @@ -849,10 +851,6 @@ hashType s = \case (BinaryNoParensType _ a b c) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c (ParensInType _ a) -> hashWithSalt s a -infixl 0 `hashTypeMaybe` -hashTypeMaybe :: Int -> Maybe (Type a) -> Int -hashTypeMaybe s Nothing = s `hashWithSalt` (0 :: Int) -hashTypeMaybe s (Just a) = s `hashType` a compareType :: Type a -> Type b -> Ordering compareType (TUnknown _ a) (TUnknown _ a') = compare a a' diff --git a/tests/TestAst.hs b/tests/TestAst.hs index 4313055550..4ec8b460b4 100644 --- a/tests/TestAst.hs +++ b/tests/TestAst.hs @@ -10,7 +10,7 @@ import Test.Hspec (Spec, describe, it) import Test.QuickCheck (Arbitrary(..), Gen, Property, Testable, counterexample, forAllShrink, subterms, (===)) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), properNameFromString, ProperNameType(..), Qualified(..), mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, OpName(..), OpNameType(..), properNameFromString, ProperNameType(..), mkQualified_, Qualified) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (Constraint, ConstraintData, SkolemScope(..), Type(..), TypeVarVisibility(..), WildcardData, annForType, everythingOnTypes, everythingWithContextOnTypes, everywhereOnTypes, everywhereOnTypesM, everywhereOnTypesTopDownM, getAnnForType) @@ -73,7 +73,7 @@ genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where genConstraintData :: Gen ConstraintData genConstraintData = genericArbitraryUG generatorEnvironment - genQualified :: forall b. Hashable b => (Text -> b) -> Gen (Qualified b) + genQualified :: forall b. Hashable b => Show b => (Text -> b) -> Gen (Qualified b) genQualified ctor = mkQualified_ ByNullSourcePos . ctor <$> genText genSkolemScope :: Gen SkolemScope From ea7bb65eff68ca8eb5fb216743c8b2e71d340c73 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Mon, 19 May 2025 20:37:40 +0000 Subject: [PATCH 10/19] Hash cons --- src/Language/PureScript/CST/Convert.hs | 5 +- src/Language/PureScript/CoreFn/CSE.hs | 4 +- src/Language/PureScript/CoreFn/Desugar.hs | 4 +- .../PureScript/Docs/Convert/Single.hs | 3 +- src/Language/PureScript/Docs/Render.hs | 3 +- .../Docs/RenderedCode/RenderType.hs | 4 +- src/Language/PureScript/Environment.hs | 12 +- src/Language/PureScript/Errors.hs | 6 +- src/Language/PureScript/Ide/Prim.hs | 3 +- src/Language/PureScript/Ide/Usage.hs | 19 +- .../PureScript/Interactive/Printer.hs | 3 +- src/Language/PureScript/Interner.hs | 236 ++++++++++-------- src/Language/PureScript/Make.hs | 4 +- src/Language/PureScript/Make/ExternsDiff.hs | 14 +- src/Language/PureScript/Names.hs | 118 ++++----- src/Language/PureScript/PSString.hs | 17 +- src/Language/PureScript/Pretty/Types.hs | 4 +- src/Language/PureScript/Sugar/Names.hs | 10 +- src/Language/PureScript/Sugar/Operators.hs | 8 +- .../PureScript/Sugar/Operators/Common.hs | 6 +- src/Language/PureScript/Sugar/TypeClasses.hs | 14 +- src/Language/PureScript/TypeChecker.hs | 6 +- .../PureScript/TypeChecker/Deriving.hs | 6 +- .../PureScript/TypeChecker/Entailment.hs | 8 +- src/Language/PureScript/TypeChecker/Kinds.hs | 16 +- src/Language/PureScript/TypeChecker/Monad.hs | 4 +- .../PureScript/TypeChecker/TypeSearch.hs | 2 +- src/Language/PureScript/TypeChecker/Types.hs | 10 +- src/Language/PureScript/Types.hs | 8 +- tests/Language/PureScript/Ide/Test.hs | 5 +- 30 files changed, 288 insertions(+), 274 deletions(-) diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index c812c92077..53ee38d598 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -38,6 +38,7 @@ import Language.PureScript.CST.Positions import Language.PureScript.CST.Print (printToken) import Language.PureScript.CST.Types import Data.Hashable (Hashable) +import Language.PureScript.Names (mapQualified) comment :: Comment a -> Maybe C.Comment comment = \case @@ -90,7 +91,7 @@ moduleName = \case go [] = Nothing go ns = Just $ N.moduleNameFromString $ Text.intercalate "." ns -qualified :: (Show a, Hashable a) => QualifiedName a -> N.Qualified a +qualified :: ( Hashable a) =>QualifiedName a -> N.Qualified a qualified q = N.mkQualified_ qb (qualName q) where qb = maybe N.ByNullSourcePos N.ByModuleName $ qualModule q @@ -530,7 +531,7 @@ convertDeclaration fileName decl = case decl of fixity = AST.Fixity assoc prec pure $ AST.FixityDeclaration ann $ case fxop of FixityValue name _ op -> do - Left $ AST.ValueFixity fixity (first ident <$> qualified name) (nameValue op) + Left $ AST.ValueFixity fixity (first ident `mapQualified` qualified name) (nameValue op) FixityType _ name _ op -> Right $ AST.TypeFixity fixity (qualified name) (nameValue op) DeclForeign _ _ _ frn -> diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 6d5c3aeae7..6caabb320b 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -26,7 +26,7 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) import Language.PureScript.CoreFn.Meta (Meta(IsSyntheticApp)) import Language.PureScript.CoreFn.Traversals (everywhereOnValues, traverseCoreFn) import Language.PureScript.Environment (dictTypeName) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, pattern Qualified, Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, pattern Qualified, Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString, mkQualified_, mapQualified) import Language.PureScript.PSString (decodeString) -- | @@ -248,7 +248,7 @@ generateIdentFor d e = at d . non mempty . at e %%<~ \case nameHint = \case App _ v1 v2 | Var _ n <- v1 - , fmap (properNameFromString . runIdent) n == fmap dictTypeName C.IsSymbol + , mapQualified (properNameFromString . runIdent) n == mapQualified dictTypeName C.IsSymbol , Literal _ (ObjectLiteral [(_, Abs _ _ (Literal _ (StringLiteral str)))]) <- v2 , Just decodedStr <- decodeString str -> decodedStr <> "IsSymbol" diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index abad09ebc6..24ca3c84ea 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -23,7 +23,7 @@ import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), getQual, runProperName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), getQual, runProperName, mkQualified_, mapQualified) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST qualified as A @@ -133,7 +133,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = , CaseAlternative [NullBinder (ssAnn ss)] (Right $ exprToCoreFn ss [] Nothing v3) ] exprToCoreFn _ com _ (A.Constructor ss name) = - Var (ss, com, Just $ getConstructorMeta name) $ fmap properToIdent name + Var (ss, com, Just $ getConstructorMeta name) $ mapQualified properToIdent name exprToCoreFn ss com _ (A.Case vs alts) = Case (ss, com, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) exprToCoreFn ss com _ (A.TypedValue _ v ty) = diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index f217d7d687..015ce5fb99 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -17,6 +17,7 @@ import Language.PureScript.Crash qualified as P import Language.PureScript.Names qualified as P import Language.PureScript.Roles qualified as P import Language.PureScript.Types qualified as P +import Language.PureScript.Names (mapQualified) -- | -- Convert a single Module, but ignore re-exports; any re-exported types or @@ -198,7 +199,7 @@ convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ _ _ _ constraints clas extractProperNames _ = [] childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance (fmap ($> ()) constraints) (classApp $> ())) - classApp = foldl' P.srcTypeApp (P.srcTypeConstructor (fmap P.coerceProperName className)) tys + classApp = foldl' P.srcTypeApp (P.srcTypeConstructor (mapQualified P.coerceProperName className)) tys convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title = Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.mkQualified_ mn (Right alias))) convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title = diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 19bead59f1..428e9235d5 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -23,6 +23,7 @@ import Language.PureScript.AST qualified as P import Language.PureScript.Environment qualified as P import Language.PureScript.Names qualified as P import Language.PureScript.Types qualified as P +import Language.PureScript.Names (mapQualified) renderKindSig :: Text -> KindInfo -> RenderedCode renderKindSig declTitle KindInfo{..} = @@ -108,7 +109,7 @@ renderChildDeclaration ChildDeclaration{..} = renderConstraint :: Constraint' -> RenderedCode renderConstraint (P.Constraint ann pn kinds tys _) = - renderType $ foldl (P.TypeApp ann) (foldl (P.KindApp ann) (P.TypeConstructor ann (fmap P.coerceProperName pn)) kinds) tys + renderType $ foldl (P.TypeApp ann) (foldl (P.KindApp ann) (P.TypeConstructor ann (mapQualified P.coerceProperName pn)) kinds) tys renderConstraints :: [Constraint'] -> Maybe RenderedCode renderConstraints constraints diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs index c6a985b09b..ca83688fea 100644 --- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs +++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs @@ -23,7 +23,7 @@ import Control.PatternArrows as PA import Language.PureScript.Crash (internalError) import Language.PureScript.Label (Label) -import Language.PureScript.Names (coerceProperName) +import Language.PureScript.Names (coerceProperName, mapQualified) import Language.PureScript.Pretty.Types (PrettyPrintConstraint, PrettyPrintType(..), convertPrettyPrintType, prettyPrintLabel) import Language.PureScript.Roles (Role, displayRole) import Language.PureScript.Types (Type, TypeVarVisibility, typeVarVisibilityPrefix) @@ -62,7 +62,7 @@ typeLiterals = mkPattern match renderConstraint :: PrettyPrintConstraint -> RenderedCode renderConstraint (pn, ks, tys) = - let instApp = foldl PPTypeApp (foldl (\a b -> PPTypeApp a (PPKindArg b)) (PPTypeConstructor (fmap coerceProperName pn)) ks) tys + let instApp = foldl PPTypeApp (foldl (\a b -> PPTypeApp a (PPKindArg b)) (PPTypeConstructor (mapQualified coerceProperName pn)) ks) tys in renderType' instApp renderConstraints :: PrettyPrintConstraint -> RenderedCode -> RenderedCode diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 33108ad158..09d971771a 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -23,7 +23,7 @@ import Data.List.NonEmpty qualified as NEL import Language.PureScript.AST.SourcePos (nullSourceAnn) import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName, runProperName, properNameFromString) +import Language.PureScript.Names (Ident, ProperName(..), ProperNameType(..), Qualified, QualifiedBy, coerceProperName, runProperName, properNameFromString, mapQualified, mapQualifiedF) import Language.PureScript.Roles (Role(..)) import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Types (SourceConstraint, SourceType, Type(..), TypeVarVisibility(..), eqType, srcTypeConstructor, freeTypeVariables) @@ -370,9 +370,9 @@ infixr 4 -:> primClass :: Qualified (ProperName 'ClassName) -> (SourceType -> SourceType) -> [(Qualified (ProperName 'TypeName), (SourceType, TypeKind))] primClass name mkKind = [ let k = mkKind kindConstraint - in (coerceProperName <$> name, (k, ExternData (nominalRolesForKind k))) + in (mapQualified coerceProperName name, (k, ExternData (nominalRolesForKind k))) , let k = mkKind kindType - in (dictTypeName . coerceProperName <$> name, (k, TypeSynonym)) + in (mapQualified (dictTypeName . coerceProperName) name, (k, TypeSynonym)) ] -- | The primitive types in the external environment with their @@ -393,7 +393,7 @@ primTypes = , (C.Number, (kindType, ExternData [])) , (C.Int, (kindType, ExternData [])) , (C.Boolean, (kindType, ExternData [])) - , (C.Partial <&> coerceProperName, (kindConstraint, ExternData [])) + , (C.Partial `mapQualifiedF` coerceProperName, (kindConstraint, ExternData [])) ] -- | This 'Map' contains all of the prim types from all Prim modules. @@ -472,8 +472,8 @@ primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, Type primTypeErrorTypes = M.fromList $ [ (C.Doc, (kindType, ExternData [])) - , (C.Fail <&> coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) - , (C.Warn <&> coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) + , (C.Fail `mapQualifiedF` coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) + , (C.Warn `mapQualifiedF` coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) , (C.Text, (kindSymbol -:> kindDoc, ExternData [Phantom])) , (C.Quote, (tyForall "k" kindType $ tyVar "k" -:> kindDoc, ExternData [Phantom])) , (C.QuoteLabel, (kindSymbol -:> kindDoc, ExternData [Phantom])) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 3837c84bba..21304fee01 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -56,8 +56,6 @@ import System.Console.ANSI qualified as ANSI import System.FilePath (makeRelative) import Text.PrettyPrint.Boxes qualified as Box import Witherable (wither) -import Data.Hashable (hash) -import Debug.Trace (trace) -- | A type of error messages data SimpleErrorMessage @@ -476,7 +474,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t gSimple (NoInstanceFound con ambig unks) = NoInstanceFound <$> overConstraintArgs (traverse f) con <*> pure ambig <*> pure unks gSimple (AmbiguousTypeVariables t uis) = AmbiguousTypeVariables <$> f t <*> pure uis - gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> traverse (traverse $ bitraverse f pure) insts + gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> traverse (traverseQualified $ bitraverse f pure) insts gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts @@ -868,7 +866,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon , row1Box , line "with type" , row2Box - , line $ "Hashes are: " <> (T.pack $ show $ u1) <> " and " <> (T.pack $ show $ u2) ] renderSimpleErrorMessage (KindsDoNotUnify k1 k2) = @@ -876,7 +873,6 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon , markCodeBox $ indent $ prettyType k1 , line "with kind" , markCodeBox $ indent $ prettyType k2 - , line $ "Hashes are: " <> (T.pack $ show $ hash k1) <> " and " <> (T.pack $ show $ hash k2) ] renderSimpleErrorMessage (ConstrainedTypeUnified t1 t2) = paras [ line "Could not match constrained type" diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 398c013755..4e0a2d9042 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -8,6 +8,7 @@ import Language.PureScript qualified as P import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Environment qualified as PEnv import Language.PureScript.Ide.Types (IdeDeclaration(..), IdeDeclarationAnn(..), IdeType(..), IdeTypeClass(..), ModuleMap, emptyAnn) +import Language.PureScript.Names (mapQualified) idePrimDeclarations :: ModuleMap [IdeDeclarationAnn] idePrimDeclarations = Map.fromList @@ -50,7 +51,7 @@ idePrimDeclarations = Map.fromList -- type declaration for every class, but we filter the types out when we -- load the Externs, so we do the same here removeClasses types classes = - Map.difference types (Map.mapKeys (map P.coerceProperName) classes) + Map.difference types (Map.mapKeys (mapQualified P.coerceProperName) classes) primTypes = annType (removeClasses PEnv.primTypes PEnv.primClasses) primBooleanTypes = annType PEnv.primBooleanTypes diff --git a/src/Language/PureScript/Ide/Usage.hs b/src/Language/PureScript/Ide/Usage.hs index 68711e50b9..1ce8945924 100644 --- a/src/Language/PureScript/Ide/Usage.hs +++ b/src/Language/PureScript/Ide/Usage.hs @@ -15,6 +15,7 @@ import Language.PureScript qualified as P import Language.PureScript.Ide.State (getAllModules, getFileState) import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util (identifierFromIdeDeclaration, namespaceForDeclaration) +import Language.PureScript.Names (mapQualified, traverseQualified) -- | -- How we find usages, given an IdeDeclaration and the module it was defined in: @@ -142,20 +143,20 @@ applySearch module_ search = | Just ideValue <- preview _IdeDeclValue (P.disqualify search) , P.isQualified search || not (P.LocalIdent (_ideValueIdent ideValue) `Set.member` scope) -> - [sp | map P.runIdent i == map identifierFromIdeDeclaration search] + [sp | mapQualified P.runIdent i == mapQualified identifierFromIdeDeclaration search] P.Constructor sp name - | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> - [sp | name == map _ideDtorName ideDtor] + | Just ideDtor <- traverseQualified (preview _IdeDeclDataConstructor) search -> + [sp | name == mapQualified _ideDtorName ideDtor] P.Op sp opName - | Just ideOp <- traverse (preview _IdeDeclValueOperator) search -> - [sp | opName == map _ideValueOpName ideOp] + | Just ideOp <- traverseQualified (preview _IdeDeclValueOperator) search -> + [sp | opName == mapQualified _ideValueOpName ideOp] _ -> [] goBinder _ binder = case binder of P.ConstructorBinder sp ctorName _ - | Just ideDtor <- traverse (preview _IdeDeclDataConstructor) search -> - [sp | ctorName == map _ideDtorName ideDtor] + | Just ideDtor <- traverseQualified (preview _IdeDeclDataConstructor) search -> + [sp | ctorName == mapQualified _ideDtorName ideDtor] P.OpBinder sp opName - | Just op <- traverse (preview _IdeDeclValueOperator) search -> - [sp | opName == map _ideValueOpName op] + | Just op <- traverseQualified (preview _IdeDeclValueOperator) search -> + [sp | opName == mapQualified _ideValueOpName op] _ -> [] diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index a229b601de..bcee912fce 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -10,6 +10,7 @@ import Data.Text (Text) import Language.PureScript qualified as P import Text.PrettyPrint.Boxes qualified as Box import Data.Hashable (Hashable) +import Language.PureScript.Names (mapQualified) -- TODO (Christoph): Text version of boxes textT :: Text -> Box.Box @@ -96,7 +97,7 @@ printModuleSignatures moduleName P.Environment{..} = showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = case (typ, M.lookup n typeSynonymsEnv) of (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> - if M.member (fmap P.coerceProperName n) typeClassesEnv + if M.member (mapQualified P.coerceProperName n) typeClassesEnv then Nothing else diff --git a/src/Language/PureScript/Interner.hs b/src/Language/PureScript/Interner.hs index 5c0170eed2..b230f63d32 100644 --- a/src/Language/PureScript/Interner.hs +++ b/src/Language/PureScript/Interner.hs @@ -1,104 +1,142 @@ -module Language.PureScript.Interner - ( Interner - , Interned - , intern - , unintern - , internText - , uninternText - , psStringInterner - , textInterner - , internPSString - , uninternPSString - , getInternedHash - ) where +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} -import Prelude -import Control.Concurrent.MVar -import Data.Map.Strict qualified as M -import Data.IntMap.Strict qualified as IM -import System.IO.Unsafe (unsafePerformIO) -import Data.Text (Text) -import Data.Word (Word16) -import Control.DeepSeq (NFData, deepseq) -import Data.String (IsString(..)) -import Data.Hashable (Hashable, hash, hashWithSalt) -import Data.Vector.Unboxed qualified as VU -import System.Random (randomIO) - --- | The opaque interned identifier -newtype Interned = Interned Int - deriving (Eq, NFData) - -instance Hashable Interned where - hashWithSalt salt (Interned i) = hashWithSalt salt i - -getInternedHash :: Interned -> Int -getInternedHash (Interned i) = i - -instance IsString Interned where - fromString s = internText (fromString s) - -instance Show Interned where - show (Interned i) = "" +module Language.PureScript.Interner where +import Prelude --- | A reusable interner structure --- param 'k' is the key (e.g., Text, Vector Word16) -data Interner k = Interner - { internerMap :: !(M.Map k Interned) - , reverseMap :: !(IM.IntMap k) - , internerId :: Int +import Control.Exception +import Control.Monad (when) +import Data.Hashable (Hashable, hash, hashWithSalt) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import GHC.Base (compareInt#, Int#, IO (..), anyToAddr#, addr2Int#) +import GHC.Exts (Any, Addr#, unsafeCoerce#) +import System.IO.Unsafe (unsafeDupablePerformIO) +import Text.ParserCombinators.ReadPrec (step) +import Text.Read (Read(..), lexP, parens, prec) +import Text.Read.Lex (Lexeme (Ident)) +import Codec.Serialise (Serialise) +import Codec.Serialise.Class (Serialise(..)) +import Control.DeepSeq (NFData (..)) +import Data.String (IsString (..)) + + + +-- | 'HashCons' with a precomputed hash and an 'IORef' to the value. +-- +-- WARNING: Do not use this type to wrap types whose Eq or Ord instances +-- allow distinguishable values to compare as equal; this will result in +-- nondeterminism or even visible mutation of semantically-immutable +-- values at runtime. +data HashCons a = HashConsC + { _hashCons_hash :: {-# UNPACK #-} !Int -- ^ Precomputed hash + , _hashCons_ref :: {-# UNPACK #-} !(IORef a) -- ^ Reference to the value } - deriving (Eq, Show) - -type InternerVar k = MVar (Interner k) - --- | Intern a key and get its Interned ID -intern :: (Hashable k, Ord k, NFData k) => InternerVar k -> k -> Interned -intern var k = unsafePerformIO $ do - k `deepseq` modifyMVar var $ \st -> do - -- Check if the key is already interned - case M.lookup k (internerMap st) of - Just i -> pure (st, i) - Nothing -> - let h = hash k - i = Interned h - m' = M.insert k i (internerMap st) - im' = IM.insert h k (reverseMap st) - in pure (st { internerMap = m', reverseMap = im' }, i) - --- | Reverse an Interned ID back to the original key -unintern :: InternerVar k -> Interned -> k -unintern var (Interned i) = unsafePerformIO $ do - Interner { reverseMap, internerId } <- readMVar var - case IM.lookup i reverseMap of - Just v -> pure v - Nothing -> error $ "Unknown interned ID: " ++ show i <> " interner: " <> show internerId - -{-# NOINLINE textInterner #-} -textInterner :: InternerVar Text -textInterner = unsafePerformIO $ randomIO >>= \r -> newMVar $ Interner M.empty IM.empty r - - -internText :: Text -> Interned -internText !t = intern textInterner t - -uninternText :: Interned -> Text -uninternText !i = unintern textInterner i - - -{-# NOINLINE psStringInterner #-} -psStringInterner :: InternerVar [Word16] -psStringInterner = unsafePerformIO $ randomIO >>= \r -> newMVar $ Interner M.empty IM.empty r - -newtype Word16Vec = Word16Vec { unVector :: VU.Vector Word16 } - deriving (Eq, Ord, NFData, Show) - -instance Hashable Word16Vec where - hashWithSalt salt (Word16Vec vec) = hashWithSalt salt (VU.toList vec) - -internPSString :: [Word16] -> Interned -internPSString !wa = intern psStringInterner wa -uninternPSString :: Interned -> [Word16] -uninternPSString !i = unintern psStringInterner i +instance (Hashable a, Serialise a) => Serialise (HashCons a) where + encode hc = encode (unHashCons hc) + decode = do + (h :: a) <- decode + pure $ hashCons h + +instance NFData a => NFData (HashCons a) where + rnf hc = rnf (unHashCons hc) + +instance (Hashable a, IsString a) => IsString (HashCons a) where + fromString s = hashCons (fromString s) + +pattern HashCons :: Hashable a => () => a -> HashCons a +pattern HashCons x <- (unHashCons -> x) where + HashCons x = hashCons x + +-- | Create a new 'HashCons'. +hashCons :: Hashable a => a -> HashCons a +hashCons a = HashConsC (hash a) $ unsafeDupablePerformIO $ newIORef a +{-# INLINE hashCons #-} + +-- | Extract the value from a 'HashCons'. +unHashCons :: HashCons a -> a +unHashCons (HashConsC _ ref) = unsafeDupablePerformIO $ readIORef ref +{-# INLINE unHashCons #-} + +-- | Show instance that displays 'HashCons' in the format "hashCons " +instance Show a => Show (HashCons a) where + showsPrec d hc = showParen (d > appPrec) $ + showString "hashCons " . showsPrec (appPrec + 1) (unHashCons hc) + where + appPrec = 10 + +-- | Read instance that parses 'HashCons' from the format "hashCons " +instance (Read a, Hashable a) => Read (HashCons a) where + readPrec = parens $ prec 10 $ do + Ident "hashCons" <- lexP + a <- step readPrec + pure $ hashCons a + +instance Eq a => Eq (HashCons a) where + HashConsC h1 ref1 == HashConsC h2 ref2 + | ref1 == ref2 = True + | h1 /= h2 = False + | otherwise = compareAndSubstitute ((==) :: a -> a -> Bool) True ref1 ref2 + {- INLINE (==) #-} + +-- | NOTE: This instance orders by hash first, and only secondarily by +-- the 'Ord' instance of 'a', to improve performance. +instance Ord a => Ord (HashCons a) where + compare (HashConsC h1 ref1) (HashConsC h2 ref2) = case compare h1 h2 of + EQ -> if ref1 == ref2 + then EQ + else compareAndSubstitute compare EQ ref1 ref2 + result -> result + {-# INLINE compare #-} + +instance Eq a => Hashable (HashCons a) where + hashWithSalt salt (HashConsC h _) = hashWithSalt salt h + {-# INLINE hashWithSalt #-} + +-- Compare the values in the IORefs with the given comparator, and if the result +-- indicates that they are equal, replace one with the other, preferring the one +-- whose pointer is lower. This is not expected to be totally stable, but it +-- should be *somewhat* stable, and should push us in direction of coalescing +-- more values. Without this, if you have a, b, and c, all with equal but +-- distinct values, and compare b == a and b == c repeatedly, but never compare +-- a == c, you could end up with the value of b flapping between that of a and +-- c, costing the worst-case equality check time repeatedly, and never settling +-- on a particular representation of the value. With this, you should settle on +-- a single value unless you get extremely unlucky with the way that addresses +-- move around. +compareAndSubstitute + :: Eq r + => (a -> a -> r) + -> r + -> IORef a + -> IORef a + -> r +compareAndSubstitute cmp eq ref1 ref2 = unsafeDupablePerformIO $ do + a1 <- readIORef ref1 + a2 <- readIORef ref2 + let result = a1 `cmp` a2 + when (result == eq) $ do + -- NOTE: These should already be forced by (==), but in the unlikely event + -- that they are not (i.e. because (==) on their type unconditionally + -- returns True), we need to ensure they are not thunks, according to the + -- documentation of anyToAddr# + evaluate a1 + evaluate a2 + -- NOTE: There is a race condition here: the addresses could change in + -- between when they are read. However, since either (or neither) swap is + -- fine, we are OK with this only working "most" of the time (which we + -- expect to be a very high fraction). + addrCmpResult <- IO $ \s -> + case anyToAddr# (unsafeCoerce# a1 :: Any) s of + (# s', addr1 #) -> case anyToAddr# (unsafeCoerce# a2 :: Any) s' of + (# s'', addr2 #) -> (# s'', addr2Int# addr1 `compareInt#` addr2Int# addr2 #) + case addrCmpResult of + LT -> writeIORef ref2 a1 + GT -> writeIORef ref1 a2 + EQ -> pure () + pure result +{-# INLINE compareAndSubstitute #-} diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index be03fa0328..66bedccf85 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -40,7 +40,7 @@ import Language.PureScript.Errors (MultipleErrors(..), SimpleErrorMessage(..), a import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile) import Language.PureScript.Linter (Name(..), lint, lintImports) import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules) -import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName) +import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName, mapQualified) import Language.PureScript.Renamer (renameInModule) import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) @@ -117,7 +117,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ let modulesExports = (\(_, _, exports) -> exports) <$> exEnv' (checked, CheckState{..}) <- runStateT (liftTypeCheckM $ typeCheckModule modulesExports desugared) $ emptyCheckState env let usedImports' = foldl' (flip $ \(fromModuleName, newtypeCtorName) -> - M.alter (Just . (fmap DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible + M.alter (Just . (mapQualified DctorName newtypeCtorName :) . fold) fromModuleName) usedImports checkConstructorImportsForCoercible -- Imports cannot be linted before type checking because we need to -- known which newtype constructors are used to solve Coercible -- constraints in order to not report them as unused. diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 91b48339ab..1d982e4721 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -18,7 +18,7 @@ import Language.PureScript.Constants.Prim (primModules) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment qualified as P import Language.PureScript.Externs qualified as P -import Language.PureScript.Names (ModuleName) +import Language.PureScript.Names (ModuleName, mapQualified) import Language.PureScript.Names qualified as P import Language.PureScript.Types qualified as P @@ -260,12 +260,12 @@ checkUsage searches decls = anyUsages check q = Any $ S.member (P.getQual q, P.disqualify q) searches' - checkType = check . map TypeRef - checkTypeOp = check . map TypeOpRef - checkValue = check . map ValueRef - checkValueOp = check . map ValueOpRef - checkCtor = check . map (ConstructorRef emptyName) - checkClass = check . map TypeClassRef + checkType = check . mapQualified TypeRef + checkTypeOp = check . mapQualified TypeOpRef + checkValue = check . mapQualified ValueRef + checkValueOp = check . mapQualified ValueOpRef + checkCtor = check . mapQualified (ConstructorRef emptyName) + checkClass = check . mapQualified TypeClassRef -- A nested traversal: pick up types in the module then traverse the structure of the types (checkUsageInTypes, _, _, _, _) = diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 055f8fa9ee..8749603755 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -1,10 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE InstanceSigs #-} -- | -- Data types for names -- -module Language.PureScript.Names (Name (..), getIdentName, getValOpName, getTypeName, getQual, disqualify, ModuleName (..), ProperName (..), runProperName, properNameFromString, OpName (..), ProperNameType (..), OpNameType (..), Qualified, mkQualified_, pattern Qualified, moduleNameFromString, InternalIdentData (..), Ident (..), coerceOpName, coerceProperName, QualifiedBy (..), runModuleName, unusedIdent, runIdent, toMaybeModuleName, pattern ByNullSourcePos, freshIdent, isQualifiedWith, isQualified, isBySourcePos, isPlainIdent, showIdent, byMaybeModuleName, disqualifyFor, getTypeOpName, getDctorName, getClassName, freshIdent', showOp, eraseOpName, isBuiltinModuleName, showQualified, qualify, mkQualified, isUnqualified) where +module Language.PureScript.Names (Name (..), getIdentName, getValOpName, getTypeName, getQual, disqualify, ModuleName (..), ProperName (..), runProperName, properNameFromString, OpName (..), ProperNameType (..), OpNameType (..), Qualified, mkQualified_, pattern Qualified, moduleNameFromString, InternalIdentData (..), Ident (..), coerceOpName, coerceProperName, QualifiedBy (..), runModuleName, unusedIdent, runIdent, toMaybeModuleName, pattern ByNullSourcePos, freshIdent, isQualifiedWith, isQualified, isBySourcePos, isPlainIdent, showIdent, byMaybeModuleName, disqualifyFor, getTypeOpName, getDctorName, getClassName, freshIdent', showOp, eraseOpName, isBuiltinModuleName, showQualified, qualify, mkQualified, isUnqualified, mapQualified, mapQualifiedF, traverseQualified) where import Prelude @@ -22,9 +23,8 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Int (Int64) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) -import Language.PureScript.Interner (Interned, uninternText, internText) -import Data.Hashable (Hashable (hashWithSalt)) -import Debug.Trace (trace, traceStack) +import Language.PureScript.Interner (HashCons, hashCons, unHashCons) +import Data.Hashable (Hashable) -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -96,7 +96,7 @@ data Ident -- | UnusedIdent -- | - -- A generated name used only for internTextal transformations + -- A generated name used only for hashConsal transformations -- | InternalIdent !InternalIdentData deriving (Show, Eq, Ord, Generic, Hashable) @@ -160,33 +160,33 @@ coerceOpName = OpName . runOpName -- | -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors. -- -newtype ProperName (a :: ProperNameType) = ProperName { unProperName :: Interned } +newtype ProperName (a :: ProperNameType) = ProperName { unProperName :: HashCons Text } deriving (Eq, Generic) deriving newtype (NFData) instance Hashable (ProperName a) properNameFromString :: Text -> ProperName a -properNameFromString = ProperName . internText +properNameFromString = ProperName . hashCons runProperName :: ProperName a -> Text -runProperName (ProperName n) = uninternText n +runProperName (ProperName n) = unHashCons n instance Show (ProperName a) where - show (ProperName i) = T.unpack $ uninternText i -- "" + show (ProperName i) = T.unpack $ unHashCons i -- "" instance Serialise (ProperName a) where - encode (ProperName n) = encode (uninternText n) - decode = ProperName . internText <$> decode + encode (ProperName n) = encode (unHashCons n) + decode = ProperName . hashCons <$> decode instance Ord (ProperName a) where - compare (ProperName a) (ProperName b) = compare (uninternText a) (uninternText b) + compare (ProperName a) (ProperName b) = compare (unHashCons a) (unHashCons b) instance ToJSON (ProperName a) where toJSON = toJSON . runProperName instance FromJSON (ProperName a) where - parseJSON = fmap (ProperName . internText) . parseJSON + parseJSON = fmap (ProperName . hashCons) . parseJSON -- | -- The closed set of proper name types. @@ -208,27 +208,27 @@ coerceProperName = properNameFromString . runProperName -- | -- Module names -- -newtype ModuleName = ModuleName Interned +newtype ModuleName = ModuleName (HashCons Text) deriving (Eq, Generic) deriving newtype (Hashable) instance Show ModuleName where - show (ModuleName i) = T.unpack $ uninternText i + show (ModuleName i) = T.unpack $ unHashCons i instance Ord ModuleName where - compare (ModuleName a) (ModuleName b) = compare (uninternText a) (uninternText b) + compare (ModuleName a) (ModuleName b) = compare (unHashCons a) (unHashCons b) instance Serialise ModuleName where - encode (ModuleName i) = encode (uninternText i) - decode = ModuleName . internText <$> decode + encode (ModuleName i) = encode (unHashCons i) + decode = ModuleName . hashCons <$> decode instance NFData ModuleName runModuleName :: ModuleName -> Text -runModuleName (ModuleName name) = uninternText name +runModuleName (ModuleName name) = unHashCons name moduleNameFromString :: Text -> ModuleName -moduleNameFromString = ModuleName . internText +moduleNameFromString = ModuleName . hashCons isBuiltinModuleName :: ModuleName -> Bool isBuiltinModuleName mn' = let mn = runModuleName mn' in mn == "Prim" || "Prim." `T.isPrefixOf` mn @@ -260,58 +260,40 @@ toMaybeModuleName (BySourcePos _) = Nothing -- | -- A qualified name, i.e. a name with an optional module name -- -data Qualified a = Qualified' QualifiedBy a Int - deriving (Functor, Foldable, Traversable, Generic, Show) +data Qualified' a = Qualified' QualifiedBy a + deriving (Functor, Foldable, Traversable, Generic, Show, Eq, Ord, Hashable) -{-# COMPLETE Qualified #-} -pattern Qualified :: (Show a, Hashable a) => QualifiedBy -> a -> Qualified a -pattern Qualified qb a <- Qualified' qb a _ where - Qualified qb a = mkQualified_ qb a - - --- instance Show a => Show (Qualified a) where --- show (Qualified' qb a _) = case qb of --- BySourcePos _ -> show a --- ByModuleName mn -> T.unpack (runModuleName mn) <> "." <> show a +instance (NFData a) => NFData (Qualified' a) +instance (Serialise a) => Serialise (Qualified' a) -instance NFData a => NFData (Qualified a) --- instance Serialise a => Serialise (Qualified a) +newtype Qualified a = QualifiedCons (HashCons (Qualified' a)) + deriving (Show, Eq, Generic) + deriving newtype (Hashable, Ord) -- TODO: ORD? -instance (Show a, Serialise a, Hashable a) => Serialise (Qualified a) where - encode (Qualified' qb a _) = encode $ QualifiedS qb a - decode = do - QualifiedS qb a <- decode - pure $ mkQualified_ qb a +instance (NFData a) => NFData (Qualified a) +instance (Serialise a, Hashable a) => Serialise (Qualified a) where + encode (QualifiedCons q) = encode (unHashCons q) + decode = QualifiedCons . hashCons <$> decode -data QualifiedS a = QualifiedS QualifiedBy a - deriving (Generic) +infixl 4 `mapQualified` -instance Serialise a => Serialise (QualifiedS a) -instance NFData a => NFData (QualifiedS a) +mapQualified :: Hashable b => (a -> b) -> Qualified a -> Qualified b +mapQualified f (QualifiedCons (unHashCons -> q)) = QualifiedCons (hashCons (fmap f q)) --- --- instance Ord a => Ord (Qualified a) where --- compare (Qualified' qb a1 _) (Qualified' qb' a2 _) = case compare qb qb' of --- EQ -> compare a1 a2 --- other -> other +infixl 4 `mapQualifiedF` -instance Hashable a => Hashable (Qualified a) where - hashWithSalt s (Qualified' _ _ h) = hashWithSalt s h +mapQualifiedF:: Hashable b => Qualified a -> (a -> b) -> Qualified b +mapQualifiedF (QualifiedCons (unHashCons -> q)) f = QualifiedCons (hashCons (fmap f q)) --- instance Eq a => Eq (Qualified a) where --- (Qualified' q a _) == (Qualified' q' a' _) = (q == q' && a == a') +traverseQualified :: (Applicative f, Hashable b) => (a -> f b) -> Qualified a -> f (Qualified b) +traverseQualified f (QualifiedCons (unHashCons -> q)) = QualifiedCons . hashCons <$> traverse f q -instance (Eq a) => Eq (Qualified a) where - (Qualified' q a h1) == (Qualified' q' a' h2) = - -- if q == q' && a == a' && h1 /= h2 then error "Hash mismatch when comparing" - (h1 == h2) || (q == q' && a == a') --- -instance Ord a => Ord (Qualified a) where - compare (Qualified' qb a1 _) (Qualified' qb' a2 _) = case compare qb qb' of - EQ -> compare a1 a2 - other -> other +{-# COMPLETE Qualified #-} +pattern Qualified :: (Show a, Hashable a) => QualifiedBy -> a -> Qualified a +pattern Qualified qb a <- QualifiedCons (unHashCons -> Qualified' qb a) where + Qualified qb a = mkQualified_ qb a showQualified :: (Show a, Hashable a) => (a -> Text) -> Qualified a -> Text @@ -331,21 +313,15 @@ qualify _ (Qualified (ByModuleName m) a) = (m, a) -- | -- Makes a qualified value from a name and module name. -- -mkQualified :: (Show a, Hashable a) => a -> ModuleName -> Qualified a +mkQualified :: ( Hashable a) =>a -> ModuleName -> Qualified a mkQualified name mn = let qb = ByModuleName mn - h = (hashWithSalt 1 qb `hashWithSalt` name) - -- in if h == -8933003785015192445 || h == 126158207429918995 - -- then traceStack ("mkQualified: " <> show qb <> " " <> show name <> " h:" <> show h) $ Qualified' qb name h - in Qualified' qb name h + in QualifiedCons (hashCons (Qualified' qb name)) -mkQualified_ :: (Show a, Hashable a) => QualifiedBy -> a -> Qualified a +mkQualified_ :: (Hashable a) => QualifiedBy -> a -> Qualified a mkQualified_ qb name = - let h = (hashWithSalt 1 qb `hashWithSalt` name) - -- in if h == -8933003785015192445 || h == 126158207429918995 - -- then traceStack ("mkQualified: " <> show qb <> " " <> show name <> " h:" <> show h) $ Qualified' qb name h - in Qualified' qb name h + QualifiedCons (hashCons (Qualified' qb name)) -- | Remove the module name from a qualified name diff --git a/src/Language/PureScript/PSString.hs b/src/Language/PureScript/PSString.hs index 961e70daf2..7ce15f7d08 100644 --- a/src/Language/PureScript/PSString.hs +++ b/src/Language/PureScript/PSString.hs @@ -35,7 +35,6 @@ import System.IO.Unsafe (unsafePerformIO) import Data.Aeson qualified as A import Data.Aeson.Types qualified as A import Data.Hashable (Hashable) -import Language.PureScript.Interner (Interned, uninternPSString, internPSString) -- | -- Strings in PureScript are sequences of UTF-16 code units, which do not @@ -51,32 +50,32 @@ import Language.PureScript.Interner (Interned, uninternPSString, internPSString) -- strings where that would be safe (i.e. when there are no lone surrogates), -- and arrays of UTF-16 code units (integers) otherwise. -- -newtype PSString = PSString { unPSString :: Interned } +newtype PSString = PSString { unPSString :: [Word16] } deriving (Eq, NFData, Generic) deriving newtype Hashable instance Ord PSString where - compare (PSString a) (PSString b) = compare (uninternPSString a) (uninternPSString b) + compare (PSString a) (PSString b) = compare a b instance Show PSString where show = show . codePoints toUTF16CodeUnits :: PSString -> [Word16] -toUTF16CodeUnits (PSString ps) = uninternPSString ps +toUTF16CodeUnits (PSString ps) = ps mkPSString :: [Word16] -> PSString -mkPSString ps = PSString $ internPSString ps +mkPSString = PSString instance Semigroup PSString where - PSString a <> PSString b = PSString $ internPSString (uninternPSString a <> uninternPSString b) + PSString a <> PSString b = PSString (a <> b) instance Monoid PSString where - mempty = PSString (internPSString []) + mempty = PSString [] mappend = (<>) instance Codec.Serialise PSString where - encode (PSString s) = Codec.encode (uninternPSString s) + encode (PSString s) = Codec.encode s decode = mkPSString <$> Codec.decode @@ -90,7 +89,7 @@ instance Codec.Serialise PSString where -- we do not export it. -- codePoints :: PSString -> String -codePoints = map (either (Char.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 diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index bd74432de4..1ddc07443f 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -28,7 +28,7 @@ import Data.Text qualified as T import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (tyFunction, tyRecord) -import Language.PureScript.Names (OpName(..), OpNameType(..), ProperName(..), runProperName, ProperNameType(..), Qualified, coerceProperName, disqualify, showQualified) +import Language.PureScript.Names (OpName(..), OpNameType(..), ProperName(..), runProperName, ProperNameType(..), Qualified, coerceProperName, disqualify, showQualified, mapQualified) import Language.PureScript.Pretty.Common (before, objectKeyRequiresQuoting) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), Type(..), TypeVarVisibility(..), WildcardData(..), eqType, rowToSortedList, typeVarVisibilityPrefix) import Language.PureScript.PSString (PSString, prettyPrintString, decodeString) @@ -112,7 +112,7 @@ constraintsAsBox tro con ty = doubleRightArrow = if troUnicode tro then "⇒" else "=>" constraintAsBox :: PrettyPrintConstraint -> Box -constraintAsBox (pn, ks, tys) = typeAsBox' (foldl PPTypeApp (foldl (\a b -> PPTypeApp a (PPKindArg b)) (PPTypeConstructor (fmap coerceProperName pn)) ks) tys) +constraintAsBox (pn, ks, tys) = typeAsBox' (foldl PPTypeApp (foldl (\a b -> PPTypeApp a (PPKindArg b)) (PPTypeConstructor (mapQualified coerceProperName pn)) ks) tys) -- | -- Generate a pretty-printed string representing a Row diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 545c6b0938..aab1e029de 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -28,7 +28,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage'', nonEmpty, parU, warnAndRethrow, warnAndRethrowWithPosition) import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..), ExternsImport(..)) import Language.PureScript.Linter.Imports (Name(..), UsedImports) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), mkQualified_, mapQualified) import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), checkImportConflicts, nullImports, primEnv) import Language.PureScript.Sugar.Names.Exports (findExportable, resolveExports) import Language.PureScript.Sugar.Names.Imports (resolveImports, resolveModuleImport) @@ -235,12 +235,12 @@ renameInModule imports (Module modSS coms mn decls exps) = <*> pure op updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Left alias)) op) = fmap (bound,) $ - ValueFixityDeclaration sa fixity . fmap Left + ValueFixityDeclaration sa fixity . mapQualified Left <$> updateValueName (mkQualified_ mn' alias) ss <*> pure op updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Right alias)) op) = fmap (bound,) $ - ValueFixityDeclaration sa fixity . fmap Right + ValueFixityDeclaration sa fixity . mapQualified Right <$> updateDataConstructorName (mkQualified_ mn' alias) ss <*> pure op updateDecl b d = @@ -424,7 +424,7 @@ renameInModule imports (Module modSS coms mn decls exps) = (Just options, _) -> do (mnNew, mnOrig) <- checkImportConflicts pos mn toName options modify $ \usedImports -> - M.insertWith (++) mnNew [fmap toName qname] usedImports + M.insertWith (++) mnNew [mapQualified toName qname] usedImports return $ mkQualified_ (ByModuleName mnOrig) name -- If the name wasn't found in our imports but was qualified then we need @@ -441,4 +441,4 @@ renameInModule imports (Module modSS coms mn decls exps) = _ -> throwUnknown where - throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname + throwUnknown = throwError . errorMessage . UnknownName . mapQualified toName $ qname diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index e4b650f3b4..058097d6ff 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -19,7 +19,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition) import Language.PureScript.Externs (ExternsFile(..), ExternsFixity(..), ExternsTypeFixity(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), freshIdent', mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), freshIdent', mkQualified_, mapQualified) import Language.PureScript.Sugar.Operators.Binders (matchBinderOperators) import Language.PureScript.Sugar.Operators.Expr (matchExprOperators) import Language.PureScript.Sugar.Operators.Types (matchTypeOperators) @@ -156,7 +156,7 @@ rebracketFiltered !caller pred_ externs m = do Just (Qualified mn' (Right alias)) -> return $ Constructor pos (mkQualified_ mn' alias) Nothing -> - throwError . errorMessage' pos . UnknownName $ fmap ValOpName op + throwError . errorMessage' pos . UnknownName $ mapQualified ValOpName op goExpr pos other = return (pos, other) goBinder :: SourceSpan -> Binder -> m (SourceSpan, Binder) @@ -168,7 +168,7 @@ rebracketFiltered !caller pred_ externs m = do Just (Qualified mn' (Right alias)) -> return (pos, ConstructorBinder pos (mkQualified_ mn' alias) [lhs, rhs]) Nothing -> - throwError . errorMessage' pos . UnknownName $ fmap ValOpName op + throwError . errorMessage' pos . UnknownName $ mapQualified ValOpName op goBinder _ BinaryNoParensBinder{} = internalError "BinaryNoParensBinder has no OpBinder" goBinder pos other = return (pos, other) @@ -179,7 +179,7 @@ rebracketFiltered !caller pred_ externs m = do Just alias -> return $ TypeConstructor ann2 alias Nothing -> - throwError . errorMessage' pos $ UnknownName $ fmap TyOpName op + throwError . errorMessage' pos $ UnknownName $ mapQualified TyOpName op goType _ other = return other -- | Indicates whether the `rebracketModule` diff --git a/src/Language/PureScript/Sugar/Operators/Common.hs b/src/Language/PureScript/Sugar/Operators/Common.hs index 7fd6df9645..984a2414f9 100644 --- a/src/Language/PureScript/Sugar/Operators/Common.hs +++ b/src/Language/PureScript/Sugar/Operators/Common.hs @@ -19,7 +19,7 @@ import Text.Parsec.Expr qualified as P import Language.PureScript.AST (Associativity(..), ErrorMessageHint(..), SourceSpan) import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..)) -import Language.PureScript.Names (OpName, Qualified, eraseOpName) +import Language.PureScript.Names (OpName, Qualified, eraseOpName, mapQualified) type Chain a = [Either a a] @@ -126,12 +126,12 @@ matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains map (\grp -> mkPositionedError chainOpSpans grp - (MixedAssociativityError (fmap (\name -> (eraseOpName <$> name, opAssoc name)) grp))) + (MixedAssociativityError (fmap (\name -> (eraseOpName `mapQualified` name, opAssoc name)) grp))) mixedAssoc ++ map (\grp -> mkPositionedError chainOpSpans grp - (NonAssociativeError (fmap (fmap eraseOpName) grp))) + (NonAssociativeError (fmap (mapQualified eraseOpName) grp))) nonAssoc mkPositionedError diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 34ed09408b..bff30a5b0c 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -30,7 +30,7 @@ import Language.PureScript.Environment (DataDeclType(..), NameKind(..), TypeClas import Language.PureScript.Errors hiding (isExported, nonEmpty) import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent, mkQualified_, mapQualified) import Language.PureScript.PSString (mkString) import Language.PureScript.Sugar.CaseDeclarations (desugarCases) import Language.PureScript.TypeClassDictionaries (superclassName) @@ -223,7 +223,7 @@ desugarDecl mn exps = go typeInstanceDictionaryDeclaration sa name' mn deps className tys desugared Left dict -> let - dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys + dictTy = foldl srcTypeApp (srcTypeConstructor (mapQualified (coerceProperName . dictTypeName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) in return $ ValueDecl sa name' Private [] [MkUnguarded (TypedValue True dict constrainedTy)] @@ -279,7 +279,7 @@ typeClassDictionaryDeclaration -> Declaration typeClassDictionaryDeclaration sa name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` - [ function unit (foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) superclass)) tyArgs) + [ function unit (foldl srcTypeApp (srcTypeConstructor (mapQualified (coerceProperName . dictTypeName) superclass)) tyArgs) | (Constraint _ superclass _ tyArgs _) <- implies ] members' = map (first runIdent . memberToNameAndType) members @@ -299,7 +299,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarati let className = mkQualified_ (ByModuleName mn) name dictIdent = Ident "dict" dictObjIdent = Ident "v" - ctor = ConstructorBinder ss (coerceProperName . dictTypeName <$> className) [VarBinder ss dictObjIdent] + ctor = ConstructorBinder ss (coerceProperName . dictTypeName `mapQualified` className) [VarBinder ss dictObjIdent] acsr = Accessor (mkString $ runIdent ident) (Var ss (mkQualified_ ByNullSourcePos dictObjIdent)) visibility = second (const TypeVarVisible) <$> args in ValueDecl sa ident Private [] @@ -329,7 +329,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = -- Lookup the type arguments and member types for the type class TypeClassData{..} <- - maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $ + maybe (throwError . errorMessage' ss . UnknownName $ mapQualified TyClassName className) return $ M.lookup (qualify mn className) m -- Replace the type arguments with the appropriate types in the member types @@ -358,9 +358,9 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = let superclasses = superClassDictionaryNames typeClassSuperclasses `zip` superclassesDicts let props = Literal ss $ ObjectLiteral $ map (first mkString) (members ++ superclasses) - dictTy = foldl srcTypeApp (srcTypeConstructor (fmap (coerceProperName . dictTypeName) className)) tys + dictTy = foldl srcTypeApp (srcTypeConstructor (mapQualified (coerceProperName . dictTypeName) className)) tys constrainedTy = quantify (foldr srcConstrainedType dictTy deps) - dict = App (Constructor ss (fmap (coerceProperName . dictTypeName) className)) props + dict = App (Constructor ss (mapQualified (coerceProperName . dictTypeName) className)) props mkTV = if unreachable then TypedValue False (Var nullSourceSpan C.I_undefined) else TypedValue True dict result = ValueDecl sa name Private [] [MkUnguarded (mkTV constrainedTy)] return result diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index eb56d2b559..af54d9c6d6 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -35,7 +35,7 @@ import Language.PureScript.Environment (DataDeclType(..), Environment(..), Funct import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, errorMessage', positionedError, rethrow, warnAndRethrow, MultipleErrors) import Language.PureScript.Linter (checkExhaustiveExpr) import Language.PureScript.Linter.Wildcards (ignoreWildcardsUnderCompleteTypeSignatures) -import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified, mkQualified_) +import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, disqualify, isPlainIdent, mkQualified, mkQualified_, mapQualified) import Language.PureScript.Roles (Role) import Language.PureScript.Sugar.Names.Env (Exports(..)) import Language.PureScript.TypeChecker.Kinds as T @@ -151,7 +151,7 @@ addTypeClass addTypeClass _ qualifiedClassName args implies dependencies ds kind = do env <- getEnv newClass <- mkNewClass - let qualName = fmap coerceProperName qualifiedClassName + let qualName = mapQualified coerceProperName qualifiedClassName hasSig = qualName `M.member` types env unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration ClassSig (disqualify qualName) kind @@ -609,7 +609,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = toImportDecl (sa, moduleName, importDeclarationType, asModuleName, _) = ImportDeclaration sa moduleName importDeclarationType asModuleName - qualify' :: Show a => Hashable a => a -> Qualified a + qualify' :: Hashable a => a -> Qualified a qualify' = mkQualified_ (ByModuleName mn) getSuperClassExportCheck = do diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 8164c0d167..2af82a880f 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -23,7 +23,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>)) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString, mkQualified_, mapQualified) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames) import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts) @@ -54,10 +54,10 @@ deriveInstance instType className strategy = do mn <- unsafeCheckCurrentModule env <- getEnv instUtc@UnwrappedTypeConstructor{ utcArgs = tys } <- maybe (internalCompilerError "invalid instance type") pure $ unwrapTypeConstructor instType - let ctorName = coerceProperName <$> utcQTyCon instUtc + let ctorName = coerceProperName `mapQualified` utcQTyCon instUtc TypeClassData{..} <- - note (errorMessage . UnknownName $ fmap TyClassName className) $ + note (errorMessage . UnknownName $ mapQualified TyClassName className) $ className `M.lookup` typeClasses env case strategy of diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 73e646f1db..7106e75f6f 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -40,7 +40,7 @@ import Language.PureScript.AST.Declarations (UnknownsHint(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName, mkQualified_, mapQualified) import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds) import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation) import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') @@ -378,7 +378,7 @@ entails SolverOptions{..} constraint context hints = let nii = namedInstanceIdentifier tcdValue in case tcdDescription of Just ty -> flip mkQualified_ (Left ty) <$> fmap (byMaybeModuleName . getQual) nii - Nothing -> fmap Right <$> nii + Nothing -> mapQualified Right <$> nii canBeGeneralized :: Type a -> Bool canBeGeneralized TUnknown{} = True @@ -421,10 +421,10 @@ entails SolverOptions{..} constraint context hints = return (useEmptyDict args) mkDictionary (IsSymbolInstance sym) _ = let fields = [ ("reflectSymbol", Abs (VarBinder nullSourceSpan UnusedIdent) (Literal nullSourceSpan (StringLiteral sym))) ] in - return $ App (Constructor nullSourceSpan (coerceProperName . dictTypeName <$> C.IsSymbol)) (Literal nullSourceSpan (ObjectLiteral fields)) + return $ App (Constructor nullSourceSpan (coerceProperName . dictTypeName `mapQualified` C.IsSymbol)) (Literal nullSourceSpan (ObjectLiteral fields)) mkDictionary (ReflectableInstance ref) _ = let fields = [ ("reflectType", Abs (VarBinder nullSourceSpan UnusedIdent) (asExpression ref)) ] in - pure $ App (Constructor nullSourceSpan (coerceProperName . dictTypeName <$> C.Reflectable)) (Literal nullSourceSpan (ObjectLiteral fields)) + pure $ App (Constructor nullSourceSpan (coerceProperName . dictTypeName `mapQualified` C.Reflectable)) (Literal nullSourceSpan (ObjectLiteral fields)) unknownsInAllCoveringSets :: (Int -> Text) -> [(Ident, SourceType, Maybe (S.Set (NEL.NonEmpty Int)))] -> [SourceType] -> S.Set (S.Set Int) -> UnknownsHint unknownsInAllCoveringSets indexToArgText tyClassMembers tyArgs coveringSets = do diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 0da78893cb..0eb16bc4da 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -51,7 +51,7 @@ import Data.Traversable (for) import Language.PureScript.Crash (HasCallStack, internalError) import Language.PureScript.Environment qualified as E import Language.PureScript.Errors -import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified, runProperName, properNameFromString, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified, runProperName, properNameFromString, mkQualified_, mapQualified) import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) @@ -168,7 +168,7 @@ inferKind = \tyToInfer -> env <- getEnv case M.lookup v (E.types env) of Nothing -> - throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v + throwError . errorMessage' (fst ann) . UnknownName . mapQualified TyName $ v Just (kind, E.LocalTypeVariable) -> do kind' <- apply kind pure (ty, kind' $> ann) @@ -176,9 +176,9 @@ inferKind = \tyToInfer -> pure (ty, kind $> ann) ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do env <- getEnv - con' <- case M.lookup (coerceProperName <$> v) (E.types env) of + con' <- case M.lookup (coerceProperName `mapQualified` v) (E.types env) of Nothing -> - throwError . errorMessage' (fst ann) . UnknownName . fmap TyClassName $ v + throwError . errorMessage' (fst ann) . UnknownName . mapQualified TyClassName $ v Just _ -> checkConstraint con ty' <- checkIsSaturatedType ty @@ -524,7 +524,7 @@ elaborateKind = \case env <- getEnv case M.lookup v (E.types env) of Nothing -> - throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v + throwError . errorMessage' (fst ann) . UnknownName . mapQualified TyName $ v Just (kind, _) -> ($> ann) <$> apply kind TypeVar ann a -> do @@ -850,7 +850,7 @@ checkConstraint SourceConstraint -> TypeCheckM SourceConstraint checkConstraint (Constraint ann clsName kinds args dat) = do - let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args + let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (mapQualified coerceProperName clsName)) kinds) args (_, kinds', args') <- unapplyTypes <$> checkKind ty E.kindConstraint pure $ Constraint ann clsName kinds' args' dat @@ -859,7 +859,7 @@ applyConstraint SourceConstraint -> TypeCheckM SourceConstraint applyConstraint (Constraint ann clsName kinds args dat) = do - let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args + let ty = foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (mapQualified coerceProperName clsName)) kinds) args (_, kinds', args') <- unapplyTypes <$> apply ty pure $ Constraint ann clsName kinds' args' dat @@ -883,7 +883,7 @@ checkInstanceDeclaration -> InstanceDeclarationArgs -> TypeCheckM InstanceDeclarationResult checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do - let ty = foldl (TypeApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) args + let ty = foldl (TypeApp ann) (TypeConstructor ann (mapQualified coerceProperName clsName)) args tyWithConstraints = foldr srcConstrainedType ty constraints freeVars = freeTypeVariables tyWithConstraints freeVarsDict <- for freeVars $ \v -> (properNameFromString v,) <$> freshKind (fst ann) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 94f11f3e07..48f5c65fa1 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -22,7 +22,7 @@ import Data.List.NonEmpty qualified as NEL import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..)) import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition) -import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified, pattern Qualified, QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString, mkQualified_) +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified, pattern Qualified, QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString, mkQualified_, mapQualified) import Language.PureScript.Pretty.Types (prettyPrintType) import Language.PureScript.Pretty.Values (prettyPrintValue) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) @@ -402,7 +402,7 @@ debugType = init . prettyPrintType 100 debugConstraint :: Constraint a -> String debugConstraint (Constraint ann clsName kinds args _) = - debugType $ foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (fmap coerceProperName clsName)) kinds) args + debugType $ foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (mapQualified coerceProperName clsName)) kinds) args debugTypes :: Environment -> [String] debugTypes = go <=< M.toList . types diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 41dd95fc6b..5bf85bd4be 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -131,5 +131,5 @@ typeSearch unsolved env st type' = in ( (first (P.mkQualified_ P.ByNullSourcePos . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) <> mapMaybe runPlainIdent (Map.toList matchingNames) - <> (first (map P.runProperName) <$> Map.toList matchingConstructors) + <> (first (mapQualified P.runProperName) <$> Map.toList matchingConstructors) , if null allLabels then Nothing else Just allLabels) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 5bb1864a5b..ab2a3bbfd0 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -50,7 +50,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage', escalateWarningWhen, internalCompilerError, onErrorMessages, onTypesInErrorMessage, parU) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified, QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent, properNameFromString, runProperName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified, QualifiedBy(..), byMaybeModuleName, coerceProperName, freshIdent, properNameFromString, runProperName, mkQualified_, mapQualified) import Language.PureScript.TypeChecker.Deriving (deriveInstance) import Language.PureScript.TypeChecker.Entailment (InstanceContext, newDictionaries, replaceTypeClassDictionaries) import Language.PureScript.TypeChecker.Kinds (checkConstraint, checkKind, checkTypeKind, kindOf, kindOfWithScopedVars, unifyKinds', unknownsWithKinds) @@ -490,7 +490,7 @@ infer' (Var ss var) = do infer' v@(Constructor _ c) = do env <- getEnv case M.lookup c (dataConstructors env) of - Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c + Nothing -> throwError . errorMessage . UnknownName . mapQualified DctorName $ c Just (_, _, ty, _) -> TypedValue' True v <$> (introduceSkolemScope <=< replaceAllTypeSynonyms $ ty) infer' (Case vals binders) = do (vals', ts) <- instantiateForBinders vals binders @@ -514,7 +514,7 @@ infer' (DeferredDictionary className tys) = do con <- checkConstraint (srcConstraint className [] tys Nothing) return $ TypedValue' False (TypeClassDictionary con dicts hints) - (foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys) + (foldl srcTypeApp (srcTypeConstructor (mapQualified coerceProperName className)) tys) infer' (TypedValue checkType val ty) = do moduleName <- unsafeCheckCurrentModule ((args, elabTy), kind) <- kindOfWithScopedVars ty @@ -635,7 +635,7 @@ inferBinder val (ConstructorBinder ss ctor binders) = do unless (expected == actual) . throwError . errorMessage' ss $ IncorrectConstructorArity ctor expected actual unifyTypes ret val M.unions <$> zipWithM inferBinder (reverse args) binders - _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor + _ -> throwError . errorMessage' ss . UnknownName . mapQualified DctorName $ ctor where peelArgs :: Type a -> ([Type a], Type a) peelArgs = go [] @@ -886,7 +886,7 @@ check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val check' v@(Constructor _ c) ty = do env <- getEnv case M.lookup c (dataConstructors env) of - Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c + Nothing -> throwError . errorMessage . UnknownName . mapQualified DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index c7b53b931c..0da9167d02 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -25,12 +25,10 @@ import GHC.Generics (Generic) import Language.PureScript.AST.SourcePos (pattern NullSourceAnn, SourceAnn, SourceSpan) import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName, showQualified) +import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName, mapQualified) import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) -import Data.Hashable (Hashable (hashWithSalt, hash)) -import GHC.Stack (HasCallStack) -import Debug.Trace (trace) +import Data.Hashable (Hashable (hashWithSalt)) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn @@ -699,7 +697,7 @@ srcInstanceType ss vars className tys = setAnnForType (ss, []) . flip (foldr $ \(tv, k) ty -> srcForAll TypeVarInvisible tv (Just k) ty Nothing) vars . flip (foldl' srcTypeApp) tys - $ srcTypeConstructor $ coerceProperName <$> className + $ srcTypeConstructor $ mapQualified coerceProperName className everywhereOnTypes :: (Type a -> Type a) -> Type a -> Type a everywhereOnTypes f = go where diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs index dcb3cb2ce2..2951db2b21 100644 --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -15,6 +15,7 @@ import System.FilePath (()) import System.Process (createProcess, getProcessExitCode, shell) import Language.PureScript qualified as P +import Language.PureScript.Names (mapQualified) defConfig :: IdeConfiguration defConfig = @@ -76,7 +77,7 @@ ideValueOp opName ident precedence assoc t = ida (IdeDeclValueOperator (IdeValueOperator (P.OpName opName) - (bimap P.Ident P.properNameFromString <$> ident) + (bimap P.Ident P.properNameFromString `mapQualified` ident) precedence (fromMaybe P.Infix assoc) t)) @@ -86,7 +87,7 @@ ideTypeOp opName ident precedence assoc k = ida (IdeDeclTypeOperator (IdeTypeOperator (P.OpName opName) - (P.properNameFromString <$> ident) + (P.properNameFromString `mapQualified` ident) precedence (fromMaybe P.Infix assoc) k)) From 51486e5039f431ea35dfec40fa880467df18b28e Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Mon, 19 May 2025 22:38:18 +0000 Subject: [PATCH 11/19] Hash maps --- perf.txt | 8 ++ src/Language/PureScript/CoreFn/Desugar.hs | 3 +- src/Language/PureScript/Docs/Convert.hs | 7 +- src/Language/PureScript/Docs/Prim.hs | 5 +- src/Language/PureScript/Environment.hs | 89 +++++++++---------- src/Language/PureScript/Externs.hs | 28 +++--- src/Language/PureScript/Ide/Prim.hs | 7 +- src/Language/PureScript/Interactive.hs | 5 +- .../PureScript/Interactive/Printer.hs | 30 ++++--- src/Language/PureScript/Linter/Exhaustive.hs | 5 +- src/Language/PureScript/Names.hs | 1 - src/Language/PureScript/Sugar/Names/Env.hs | 9 +- src/Language/PureScript/Sugar/TypeClasses.hs | 23 ++--- src/Language/PureScript/TypeChecker.hs | 61 ++++++------- .../PureScript/TypeChecker/Deriving.hs | 10 +-- .../PureScript/TypeChecker/Entailment.hs | 4 +- .../TypeChecker/Entailment/Coercible.hs | 5 +- src/Language/PureScript/TypeChecker/Kinds.hs | 11 +-- src/Language/PureScript/TypeChecker/Monad.hs | 36 ++++---- src/Language/PureScript/TypeChecker/Roles.hs | 19 ++-- .../PureScript/TypeChecker/Synonyms.hs | 11 +-- .../PureScript/TypeChecker/TypeSearch.hs | 13 +-- src/Language/PureScript/TypeChecker/Types.hs | 27 +++--- tests/TestPrimDocs.hs | 4 +- 24 files changed, 222 insertions(+), 199 deletions(-) create mode 100644 perf.txt diff --git a/perf.txt b/perf.txt new file mode 100644 index 0000000000..1fb17f7e30 --- /dev/null +++ b/perf.txt @@ -0,0 +1,8 @@ +# HashCons + +stat A: min 15ms max 16ms mean 16ms median 16ms stddev 0ms n=14 +stat B: min 13ms max 14ms mean 14ms median 14ms stddev 0ms n=14 +mean diff -13.4% +ttest detected diff? true p-value 0.000000 +stat ratios: min -14.90% max -10.91% mean -13.35% median -13.25% stddev 0.94% n=14 +ttest detected ratios diff? true p-value 0.000000 diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 24ca3c84ea..874865f4a8 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -29,6 +29,7 @@ import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST qualified as A import Language.PureScript.Constants.Prim qualified as C import Data.Hashable (Hashable) +import Data.HashMap.Strict qualified as HM -- | Desugars a module from AST to CoreFn representation. moduleToCoreFn :: Environment -> A.Module -> Module Ann @@ -210,7 +211,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = numConstructors :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) -> Int - numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env + numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ HM.toList $ dataConstructors env typeConstructor :: (Qualified (ProperName 'ConstructorName), (DataDeclType, ProperName 'TypeName, SourceType, [Ident])) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index a8d7487812..58d00a5709 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -29,6 +29,7 @@ import Language.PureScript.Sugar qualified as P import Language.PureScript.Types qualified as P import Language.PureScript.Constants.Prim qualified as Prim import Language.PureScript.Sugar (RebracketCaller(CalledByDocs)) +import Data.HashMap.Strict qualified as HM -- | -- Convert a single module to a Docs.Module, making use of a pre-existing @@ -84,7 +85,7 @@ insertValueTypesAndAdjustKinds env m = inferredRoles :: [P.Role] inferredRoles = do let key = P.mkQualified_ (P.ByModuleName (modName m)) (P.properNameFromString (declTitle d)) - case Map.lookup key (P.types env) of + case HM.lookup key (P.types env) of Just (_, tyKind) -> case tyKind of P.DataType _ tySourceTyRole _ -> map (\(_,_,r) -> r) tySourceTyRole @@ -163,7 +164,7 @@ insertValueTypesAndAdjustKinds env m = lookupName name = let key = P.mkQualified_ (P.ByModuleName (modName m)) name - in case Map.lookup key (P.names env) of + in case HM.lookup key (P.names env) of Just (ty, _, _) -> ty Nothing -> @@ -214,7 +215,7 @@ insertValueTypesAndAdjustKinds env m = insertInferredKind d name keyword = let key = P.mkQualified_ (P.ByModuleName (modName m)) (P.properNameFromString name) - in case Map.lookup key (P.types env) of + in case HM.lookup key (P.types env) of Just (inferredKind, _) -> if isUninteresting keyword inferredKind' then d diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 801a64bc6f..37fd86ab79 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -17,6 +17,7 @@ import Language.PureScript.Constants.Prim qualified as P import Language.PureScript.Crash qualified as P import Language.PureScript.Environment qualified as P import Language.PureScript.Names qualified as P +import Data.HashMap.Strict qualified as HM primModules :: [Module] primModules = @@ -161,13 +162,13 @@ primTypeErrorDocsModule = Module unsafeLookup :: forall v (a :: P.ProperNameType) - . Map.Map (P.Qualified (P.ProperName a)) v + . HM.HashMap (P.Qualified (P.ProperName a)) v -> String -> P.Qualified (P.ProperName a) -> v unsafeLookup m errorMsg name = go name where - go = fromJust' . flip Map.lookup m + go = fromJust' . flip HM.lookup m fromJust' (Just x) = x fromJust' _ = P.internalError $ errorMsg ++ show (P.runProperName $ P.disqualify name) diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 09d971771a..49fc12492f 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -9,7 +9,6 @@ import Codec.Serialise (Serialise) import Data.Aeson ((.=), (.:)) import Data.Aeson qualified as A import Data.Foldable (find, fold) -import Data.Functor ((<&>)) import Data.IntMap qualified as IM import Data.IntSet qualified as IS import Data.HashMap.Strict qualified as HM @@ -31,20 +30,20 @@ import Language.PureScript.Constants.Prim qualified as C -- | The @Environment@ defines all values and types which are currently in scope: data Environment = Environment - { names :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) + { names :: HM.HashMap (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Values currently in scope - , types :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) + , types :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) -- ^ Type names currently in scope - , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) + , dataConstructors :: HM.HashMap (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) -- ^ Data constructors currently in scope, along with their associated type -- constructor name, argument types and return type. - , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) + , typeSynonyms :: HM.HashMap (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) -- ^ Type synonyms currently in scope , typeClassDictionaries :: HM.HashMap QualifiedBy (HM.HashMap (Qualified (ProperName 'ClassName)) (HM.HashMap (Qualified Ident) (NEL.NonEmpty NamedDict))) -- ^ Available type class dictionaries. When looking up 'Nothing' in the -- outer map, this returns the map of type class dictionaries in local -- scope (ie dictionaries brought in by a constrained type). - , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData + , typeClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData -- ^ Type classes } deriving (Show, Generic) @@ -102,7 +101,7 @@ instance A.ToJSON FunctionalDependency where -- | The initial environment with no values and only the default javascript types defined initEnvironment :: Environment -initEnvironment = Environment M.empty allPrimTypes M.empty M.empty HM.empty allPrimClasses +initEnvironment = Environment HM.empty allPrimTypes HM.empty HM.empty HM.empty allPrimClasses -- | A constructor for TypeClassData that computes which type class arguments are fully determined -- and argument covering sets. @@ -378,9 +377,9 @@ primClass name mkKind = -- | The primitive types in the external environment with their -- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types -- that correspond to the classes with the same names. -primTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypes = - M.fromList + HM.fromList [ (C.Type, (kindType, ExternData [])) , (C.Constraint, (kindType, ExternData [])) , (C.Symbol, (kindType, ExternData [])) @@ -397,8 +396,8 @@ primTypes = ] -- | This 'Map' contains all of the prim types from all Prim modules. -allPrimTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) -allPrimTypes = M.unions +allPrimTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +allPrimTypes = HM.unions [ primTypes , primBooleanTypes , primCoerceTypes @@ -410,40 +409,40 @@ allPrimTypes = M.unions , primTypeErrorTypes ] -primBooleanTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primBooleanTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primBooleanTypes = - M.fromList + HM.fromList [ (C.True, (tyBoolean, ExternData [])) , (C.False, (tyBoolean, ExternData [])) ] -primCoerceTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primCoerceTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primCoerceTypes = - M.fromList $ mconcat + HM.fromList $ mconcat [ primClass C.Coercible (\kind -> tyForall "k" kindType $ tyVar "k" -:> tyVar "k" -:> kind) ] -primOrderingTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primOrderingTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primOrderingTypes = - M.fromList + HM.fromList [ (C.TypeOrdering, (kindType, ExternData [])) , (C.LT, (kindOrdering, ExternData [])) , (C.EQ, (kindOrdering, ExternData [])) , (C.GT, (kindOrdering, ExternData [])) ] -primRowTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primRowTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowTypes = - M.fromList $ mconcat + HM.fromList $ mconcat [ primClass C.RowUnion (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) , primClass C.RowNub (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) , primClass C.RowLacks (\kind -> tyForall "k" kindType $ kindSymbol -:> kindRow (tyVar "k") -:> kind) , primClass C.RowCons (\kind -> tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRow (tyVar "k") -:> kindRow (tyVar "k") -:> kind) ] -primRowListTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primRowListTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primRowListTypes = - M.fromList $ + HM.fromList $ [ (C.RowList, (kindType -:> kindType, ExternData [Phantom])) , (C.RowListCons, (tyForall "k" kindType $ kindSymbol -:> tyVar "k" -:> kindRowList (tyVar "k") -:> kindRowList (tyVar "k"), ExternData [Phantom, Phantom, Phantom])) , (C.RowListNil, (tyForall "k" kindType $ kindRowList (tyVar "k"), ExternData [])) @@ -451,26 +450,26 @@ primRowListTypes = [ primClass C.RowToList (\kind -> tyForall "k" kindType $ kindRow (tyVar "k") -:> kindRowList (tyVar "k") -:> kind) ] -primSymbolTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primSymbolTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primSymbolTypes = - M.fromList $ mconcat + HM.fromList $ mconcat [ primClass C.SymbolAppend (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) , primClass C.SymbolCompare (\kind -> kindSymbol -:> kindSymbol -:> kindOrdering -:> kind) , primClass C.SymbolCons (\kind -> kindSymbol -:> kindSymbol -:> kindSymbol -:> kind) ] -primIntTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primIntTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primIntTypes = - M.fromList $ mconcat + HM.fromList $ mconcat [ primClass C.IntAdd (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) , primClass C.IntCompare (\kind -> tyInt -:> tyInt -:> kindOrdering -:> kind) , primClass C.IntMul (\kind -> tyInt -:> tyInt -:> tyInt -:> kind) , primClass C.IntToString (\kind -> tyInt -:> kindSymbol -:> kind) ] -primTypeErrorTypes :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +primTypeErrorTypes :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) primTypeErrorTypes = - M.fromList $ + HM.fromList $ [ (C.Doc, (kindType, ExternData [])) , (C.Fail `mapQualifiedF` coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) , (C.Warn `mapQualifiedF` coerceProperName, (kindDoc -:> kindConstraint, ExternData [Nominal])) @@ -486,15 +485,15 @@ primTypeErrorTypes = -- | The primitive class map. This just contains the `Partial` class. -- `Partial` is used as a kind of magic constraint for partial functions. -primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData primClasses = - M.fromList + HM.fromList [ (C.Partial, makeTypeClassData [] [] [] [] True) ] -- | This contains all of the type classes from all Prim modules. -allPrimClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData -allPrimClasses = M.unions +allPrimClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData +allPrimClasses = HM.unions [ primClasses , primCoerceClasses , primRowClasses @@ -504,9 +503,9 @@ allPrimClasses = M.unions , primTypeErrorClasses ] -primCoerceClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primCoerceClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData primCoerceClasses = - M.fromList + HM.fromList -- class Coercible (a :: k) (b :: k) [ (C.Coercible, makeTypeClassData [ ("a", Just (tyVar "k")) @@ -514,9 +513,9 @@ primCoerceClasses = ] [] [] [] True) ] -primRowClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primRowClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData primRowClasses = - M.fromList + HM.fromList -- class Union (left :: Row k) (right :: Row k) (union :: Row k) | left right -> union, right union -> left, union left -> right [ (C.RowUnion, makeTypeClassData [ ("left", Just (kindRow (tyVar "k"))) @@ -554,9 +553,9 @@ primRowClasses = ] True) ] -primRowListClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primRowListClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData primRowListClasses = - M.fromList + HM.fromList -- class RowToList (row :: Row k) (list :: RowList k) | row -> list [ (C.RowToList, makeTypeClassData [ ("row", Just (kindRow (tyVar "k"))) @@ -566,9 +565,9 @@ primRowListClasses = ] True) ] -primSymbolClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primSymbolClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData primSymbolClasses = - M.fromList + HM.fromList -- class Append (left :: Symbol) (right :: Symbol) (appended :: Symbol) | left right -> appended, right appended -> left, appended left -> right [ (C.SymbolAppend, makeTypeClassData [ ("left", Just kindSymbol) @@ -600,9 +599,9 @@ primSymbolClasses = ] True) ] -primIntClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primIntClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData primIntClasses = - M.fromList + HM.fromList -- class Add (left :: Int) (right :: Int) (sum :: Int) | left right -> sum, left sum -> right, right sum -> left [ (C.IntAdd, makeTypeClassData [ ("left", Just tyInt) @@ -641,9 +640,9 @@ primIntClasses = ] True) ] -primTypeErrorClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData +primTypeErrorClasses :: HM.HashMap (Qualified (ProperName 'ClassName)) TypeClassData primTypeErrorClasses = - M.fromList + HM.fromList -- class Fail (message :: Symbol) [ (C.Fail, makeTypeClassData [("message", Just kindDoc)] [] [] [] True) @@ -656,11 +655,11 @@ primTypeErrorClasses = -- | Finds information about data constructors from the current environment. lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) lookupConstructor env ctor = - fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env + fromMaybe (internalError "Data constructor not found") $ ctor `HM.lookup` dataConstructors env -- | Finds information about values from the current environment. lookupValue :: Environment -> Qualified Ident -> Maybe (SourceType, NameKind, NameVisibility) -lookupValue env ident = ident `M.lookup` names env +lookupValue env ident = ident `HM.lookup` names env dictTypeName' :: Text -> Text dictTypeName' = (<> "$Dict") diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 94abc247b4..e40e310185 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -178,11 +178,11 @@ applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations where applyDecl :: Environment -> ExternsDeclaration -> Environment - applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) } - applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) } - applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } - applyDecl env (EDValue ident ty) = env { names = M.insert (mkQualified_ (ByModuleName efModuleName) ident) (ty, External, Defined) (names env) } - applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } + applyDecl env (EDType pn kind tyKind) = env { types = HM.insert (qual pn) (kind, tyKind) (types env) } + applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = HM.insert (qual pn) (args, ty) (typeSynonyms env) } + applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = HM.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } + applyDecl env (EDValue ident ty) = env { names = HM.insert (mkQualified_ (ByModuleName efModuleName) ident) (ty, External, Defined) (names env) } + applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = HM.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) } applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) = env { typeClassDictionaries = updateHMap @@ -200,7 +200,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar CompilerNamed -> Just $ srcInstanceType ss vars className tys UserNamed -> Nothing - qual :: (Show a, Hashable a) => a -> Qualified a + qual :: ( Hashable a) =>a -> Qualified a qual = mkQualified_ (ByModuleName efModuleName) -- | Generate an externs file for all declarations in a module. @@ -239,26 +239,26 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] toExternsDeclaration (TypeRef _ pn dctors) = - case mkQualified_ (ByModuleName mn) pn `M.lookup` types env of + case mkQualified_ (ByModuleName mn) pn `HM.lookup` types env of Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration" Just (kind, TypeSynonym) - | Just (args, synTy) <- mkQualified_ (ByModuleName mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] + | Just (args, synTy) <- mkQualified_ (ByModuleName mn) pn `HM.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ] Just (kind, ExternData rs) -> [ EDType pn kind (ExternData rs) ] Just (kind, tk@(DataType _ _ tys)) -> EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args | dctor <- fromMaybe (map fst tys) dctors - , (dty, _, ty, args) <- maybeToList (mkQualified_ (ByModuleName mn) dctor `M.lookup` dataConstructors env) + , (dty, _, ty, args) <- maybeToList (mkQualified_ (ByModuleName mn) dctor `HM.lookup` dataConstructors env) ] _ -> internalError "toExternsDeclaration: Invalid input" toExternsDeclaration (ValueRef _ ident) - | Just (ty, _, _) <- mkQualified_ (ByModuleName mn) ident `M.lookup` names env + | Just (ty, _, _) <- mkQualified_ (ByModuleName mn) ident `HM.lookup` names env = [ EDValue (lookupRenamedIdent ident) ty ] toExternsDeclaration (TypeClassRef _ className) | let dictName = dictTypeName . coerceProperName $ className - , Just TypeClassData{..} <- mkQualified_ (ByModuleName mn) className `M.lookup` typeClasses env - , Just (kind, tk) <- mkQualified_ (ByModuleName mn) (coerceProperName className) `M.lookup` types env - , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- mkQualified_ (ByModuleName mn) dictName `M.lookup` types env - , Just (dty, _, ty, args) <- mkQualified_ (ByModuleName mn) dctor `M.lookup` dataConstructors env + , Just TypeClassData{..} <- mkQualified_ (ByModuleName mn) className `HM.lookup` typeClasses env + , Just (kind, tk) <- mkQualified_ (ByModuleName mn) (coerceProperName className) `HM.lookup` types env + , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- mkQualified_ (ByModuleName mn) dictName `HM.lookup` types env + , Just (dty, _, ty, args) <- mkQualified_ (ByModuleName mn) dctor `HM.lookup` dataConstructors env = [ EDType (coerceProperName className) kind tk , EDType dictName dictKind dictData , EDDataConstructor dctor dty dictName ty args diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs index 4e0a2d9042..f24fe8ada9 100644 --- a/src/Language/PureScript/Ide/Prim.hs +++ b/src/Language/PureScript/Ide/Prim.hs @@ -9,6 +9,7 @@ import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Environment qualified as PEnv import Language.PureScript.Ide.Types (IdeDeclaration(..), IdeDeclarationAnn(..), IdeType(..), IdeTypeClass(..), ModuleMap, emptyAnn) import Language.PureScript.Names (mapQualified) +import Data.HashMap.Strict qualified as HM idePrimDeclarations :: ModuleMap [IdeDeclarationAnn] idePrimDeclarations = Map.fromList @@ -38,20 +39,20 @@ idePrimDeclarations = Map.fromList ) ] where - annType tys = flip mapMaybe (Map.toList tys) $ \(tn, (kind, _)) -> do + annType tys = flip mapMaybe (HM.toList tys) $ \(tn, (kind, _)) -> do let name = P.disqualify tn -- We need to remove the ClassName$Dict synonyms, because we -- don't want them to show up in completions guard (isNothing (T.find (== '$') (P.runProperName name))) Just (IdeDeclarationAnn emptyAnn (IdeDeclType (IdeType name kind []))) - annClass cls = foreach (Map.toList cls) $ \(cn, _) -> + annClass cls = foreach (HM.toList cls) $ \(cn, _) -> -- Dummy kind and instances here, but we primarily care about the name completion IdeDeclarationAnn emptyAnn (IdeDeclTypeClass (IdeTypeClass (P.disqualify cn) P.kindType []) ) -- The Environment for typechecking holds both a type class as well as a -- type declaration for every class, but we filter the types out when we -- load the Externs, so we do the same here removeClasses types classes = - Map.difference types (Map.mapKeys (mapQualified P.coerceProperName) classes) + HM.difference types (HM.mapKeys (mapQualified P.coerceProperName) classes) primTypes = annType (removeClasses PEnv.primTypes PEnv.primClasses) primBooleanTypes = annType PEnv.primBooleanTypes diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index 92c783f3dd..05f4e8f1d1 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -45,6 +45,7 @@ import System.Directory (getCurrentDirectory) import System.FilePath (()) import System.FilePath.Glob (glob) import Language.PureScript.TypeChecker.Monad (liftTypeCheckM) +import Data.HashMap.Strict qualified as HM -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () @@ -276,7 +277,7 @@ handleTypeOf print' val = do case e of Left errs -> printErrors errs Right (_, env') -> - case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName "$PSCI")) (P.names env') of + case HM.lookup (P.mkQualified (P.Ident "it") (P.ModuleName "$PSCI")) (P.names env') of Just (ty, _, _) -> print' . P.prettyPrintType maxBound $ ty Nothing -> print' "Could not find type" @@ -294,7 +295,7 @@ handleKindOf print' typ = do case e of Left errs -> printErrors errs Right (_, env') -> - case M.lookup (P.mkQualified_ (P.ByModuleName mName) $ P.ProperName "IT") (P.typeSynonyms env') of + case HM.lookup (P.mkQualified_ (P.ByModuleName mName) $ P.ProperName "IT") (P.typeSynonyms env') of Just (_, typ') -> do let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName } k = check (snd <$> liftTypeCheckM (P.kindOf typ')) chk diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index bcee912fce..8264ef2d10 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -11,6 +11,7 @@ import Language.PureScript qualified as P import Text.PrettyPrint.Boxes qualified as Box import Data.Hashable (Hashable) import Language.PureScript.Names (mapQualified) +import Data.HashMap.Strict qualified as HM -- TODO (Christoph): Text version of boxes textT :: Text -> Box.Box @@ -28,8 +29,9 @@ printModuleSignatures moduleName P.Environment{..} = moduleTypeClasses = byModuleName typeClasses moduleTypes = byModuleName types - byModuleName :: Show a => Hashable a => M.Map (P.Qualified a) b -> [P.Qualified a] - byModuleName = filter ((== Just moduleName) . P.getQual) . M.keys + + byModuleName :: Show a => Hashable a => HM.HashMap (P.Qualified a) b -> [P.Qualified a] + byModuleName = filter ((== Just moduleName) . P.getQual) . HM.keys in -- print each component @@ -41,20 +43,20 @@ printModuleSignatures moduleName P.Environment{..} = where printModule's showF = Box.vsep 1 Box.left . showF - findNameType :: M.Map (P.Qualified P.Ident) (P.SourceType, P.NameKind, P.NameVisibility) + findNameType :: HM.HashMap (P.Qualified P.Ident) (P.SourceType, P.NameKind, P.NameVisibility) -> P.Qualified P.Ident -> (P.Ident, Maybe (P.SourceType, P.NameKind, P.NameVisibility)) - findNameType envNames m = (P.disqualify m, M.lookup m envNames) + findNameType envNames m = (P.disqualify m, HM.lookup m envNames) showNameType :: (P.Ident, Maybe (P.SourceType, P.NameKind, P.NameVisibility)) -> Box.Box showNameType (mIdent, Just (mType, _, _)) = textT (P.showIdent mIdent <> " :: ") Box.<> P.typeAsBox maxBound mType showNameType _ = P.internalError "The impossible happened in printModuleSignatures." findTypeClass - :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData + :: HM.HashMap (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData -> P.Qualified (P.ProperName 'P.ClassName) -> (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData) - findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses) + findTypeClass envTypeClasses name = (name, HM.lookup name envTypeClasses) showTypeClass :: (P.Qualified (P.ProperName 'P.ClassName), Maybe P.TypeClassData) @@ -83,21 +85,21 @@ printModuleSignatures moduleName P.Environment{..} = findType - :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.SourceType, P.TypeKind) + :: HM.HashMap (P.Qualified (P.ProperName 'P.TypeName)) (P.SourceType, P.TypeKind) -> P.Qualified (P.ProperName 'P.TypeName) -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceType, P.TypeKind)) - findType envTypes name = (name, M.lookup name envTypes) + findType envTypes name = (name, HM.lookup name envTypes) showType - :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData - -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) - -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.SourceType)], P.SourceType) + :: HM.HashMap (P.Qualified (P.ProperName 'P.ClassName)) P.TypeClassData + -> HM.HashMap (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.SourceType, [P.Ident]) + -> HM.HashMap (P.Qualified (P.ProperName 'P.TypeName)) ([(Text, Maybe P.SourceType)], P.SourceType) -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.SourceType, P.TypeKind)) -> Maybe Box.Box showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) = - case (typ, M.lookup n typeSynonymsEnv) of + case (typ, HM.lookup n typeSynonymsEnv) of (Just (_, P.TypeSynonym), Just (typevars, dtType)) -> - if M.member (mapQualified P.coerceProperName n) typeClassesEnv + if HM.member (mapQualified P.coerceProperName n) typeClassesEnv then Nothing else @@ -109,7 +111,7 @@ printModuleSignatures moduleName P.Environment{..} = let prefix = case pt of [(dtProperName,_)] -> - case M.lookup (P.mkQualified_ modul dtProperName) dataConstructorsEnv of + case HM.lookup (P.mkQualified_ modul dtProperName) dataConstructorsEnv of Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType _ -> "data" _ -> "data" diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index f4466d5cd2..62ec7c1a54 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -31,6 +31,7 @@ import Language.PureScript.Names as P import Language.PureScript.Pretty.Values (prettyPrintBinderAtom) import Language.PureScript.Types as P import Language.PureScript.Constants.Prim qualified as C +import Data.HashMap.Strict qualified as HM -- | There are two modes of failure for the redundancy check: -- @@ -67,7 +68,7 @@ getConstructors env defmn n = extractConstructors lnte extractConstructors _ = internalError "Data name not in the scope of the current environment in extractConstructors" lnte :: Maybe (SourceType, TypeKind) - lnte = M.lookup qpn (types env) + lnte = HM.lookup qpn (types env) qpn :: Qualified (ProperName 'TypeName) qpn = getConsDataName n @@ -79,7 +80,7 @@ getConstructors env defmn n = extractConstructors lnte Just (_, pm, _, _) -> qualifyName pm defmn con getConsInfo :: Qualified (ProperName 'ConstructorName) -> Maybe (DataDeclType, ProperName 'TypeName, SourceType, [Ident]) - getConsInfo con = M.lookup con (dataConstructors env) + getConsInfo con = HM.lookup con (dataConstructors env) -- | -- Replicates a wildcard binder diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 8749603755..926cc13c54 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -323,7 +323,6 @@ mkQualified_ :: (Hashable a) => QualifiedBy -> a -> Qualified a mkQualified_ qb name = QualifiedCons (hashCons (Qualified' qb name)) - -- | Remove the module name from a qualified name disqualify :: (Show a, Hashable a) => Qualified a -> a disqualify (Qualified _ a) = a diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 346ba29a45..a17b71a871 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -39,6 +39,7 @@ import Language.PureScript.Environment import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual, mkQualified_) import Data.Hashable (Hashable) +import Data.HashMap.Strict qualified as HM -- | -- The details for an import: the name of the thing that is being imported @@ -221,13 +222,13 @@ primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses -- Create a set of exports for a Prim module. -- mkPrimExports - :: M.Map (Qualified (ProperName 'TypeName)) a - -> M.Map (Qualified (ProperName 'ClassName)) b + :: HM.HashMap (Qualified (ProperName 'TypeName)) a + -> HM.HashMap (Qualified (ProperName 'ClassName)) b -> Exports mkPrimExports ts cs = nullExports - { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys ts - , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys cs + { exportedTypes = M.fromList $ mkTypeEntry `map` HM.keys ts + , exportedTypeClasses = M.fromList $ mkClassEntry `map` HM.keys cs } where mkTypeEntry (Qualified (ByModuleName mn) name) = (name, ([], primExportSource mn)) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index bff30a5b0c..c0da3bb8e8 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -35,8 +35,9 @@ import Language.PureScript.PSString (mkString) import Language.PureScript.Sugar.CaseDeclarations (desugarCases) import Language.PureScript.TypeClassDictionaries (superclassName) import Language.PureScript.Types +import Data.HashMap.Strict qualified as HM -type MemberMap = M.Map (ModuleName, ProperName 'ClassName) TypeClassData +type MemberMap = HM.HashMap (ModuleName, ProperName 'ClassName) TypeClassData type Desugar = StateT MemberMap @@ -54,14 +55,14 @@ desugarTypeClasses externs = flip evalStateT initialState . desugarModule initialState :: MemberMap initialState = mconcat - [ M.mapKeys (qualify C.M_Prim) primClasses - , M.mapKeys (qualify C.M_Prim_Coerce) primCoerceClasses - , M.mapKeys (qualify C.M_Prim_Row) primRowClasses - , M.mapKeys (qualify C.M_Prim_RowList) primRowListClasses - , M.mapKeys (qualify C.M_Prim_Symbol) primSymbolClasses - , M.mapKeys (qualify C.M_Prim_Int) primIntClasses - , M.mapKeys (qualify C.M_Prim_TypeError) primTypeErrorClasses - , M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + [ HM.mapKeys (qualify C.M_Prim) primClasses + , HM.mapKeys (qualify C.M_Prim_Coerce) primCoerceClasses + , HM.mapKeys (qualify C.M_Prim_Row) primRowClasses + , HM.mapKeys (qualify C.M_Prim_RowList) primRowListClasses + , HM.mapKeys (qualify C.M_Prim_Symbol) primSymbolClasses + , HM.mapKeys (qualify C.M_Prim_Int) primIntClasses + , HM.mapKeys (qualify C.M_Prim_TypeError) primTypeErrorClasses + , HM.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) ] fromExternsDecl @@ -205,7 +206,7 @@ desugarDecl desugarDecl mn exps = go where go d@(TypeClassDeclaration sa name args implies deps members) = do - modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) + modify (HM.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps False)) return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) go (TypeInstanceDeclaration sa na chainId idx name deps className tys body) = do name' <- desugarInstName name @@ -330,7 +331,7 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls = -- Lookup the type arguments and member types for the type class TypeClassData{..} <- maybe (throwError . errorMessage' ss . UnknownName $ mapQualified TyClassName className) return $ - M.lookup (qualify mn className) m + HM.lookup (qualify mn className) m -- Replace the type arguments with the appropriate types in the member types let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys)) . tuple3To2) typeClassMembers diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index af54d9c6d6..91f4d7117b 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-dodgy-imports #-} -- | -- The top-level type checker, which checks all declarations in a module. -- @@ -61,8 +62,8 @@ addDataType moduleName dtype name args dctors ctorKind = do env <- getEnv let mapDataCtor (DataConstructorDeclaration _ ctorName vars) = (ctorName, snd <$> vars) qualName = mkQualified_ (ByModuleName moduleName) name - hasSig = qualName `M.member` types env - putEnv $ env { types = M.insert qualName (ctorKind, DataType dtype args (map (mapDataCtor . fst) dctors)) (types env) } + hasSig = qualName `HM.member` types env + putEnv $ env { types = HM.insert qualName (ctorKind, DataType dtype args (map (mapDataCtor . fst) dctors)) (types env) } unless (hasSig || isDictTypeName name || not (containsForAll ctorKind)) $ do tell . errorMessage $ MissingKindDeclaration (if dtype == Newtype then NewtypeSig else DataSig) name ctorKind for_ dctors $ \(DataConstructorDeclaration _ dctor fields, polyType) -> @@ -81,7 +82,7 @@ addDataConstructor moduleName dtype name dctor dctorArgs polyType = do let fields = fst <$> dctorArgs env <- getEnv checkTypeSynonyms polyType - putEnv $ env { dataConstructors = M.insert (mkQualified_ (ByModuleName moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } + putEnv $ env { dataConstructors = HM.insert (mkQualified_ (ByModuleName moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) } checkRoleDeclaration :: ModuleName @@ -91,15 +92,15 @@ checkRoleDeclaration moduleName (RoleDeclarationData (ss, _) name declaredRoles) warnAndRethrow (addHint (ErrorInRoleDeclaration name) . addHint (positionedError ss)) $ do env <- getEnv let qualName = mkQualified_ (ByModuleName moduleName) name - case M.lookup qualName (types env) of + case HM.lookup qualName (types env) of Just (kind, DataType dtype args dctors) -> do checkRoleDeclarationArity name declaredRoles (length args) checkRoles args declaredRoles let args' = zipWith (\(v, k, _) r -> (v, k, r)) args declaredRoles - putEnv $ env { types = M.insert qualName (kind, DataType dtype args' dctors) (types env) } + putEnv $ env { types = HM.insert qualName (kind, DataType dtype args' dctors) (types env) } Just (kind, ExternData _) -> do checkRoleDeclarationArity name declaredRoles (kindArity kind) - putEnv $ env { types = M.insert qualName (kind, ExternData declaredRoles) (types env) } + putEnv $ env { types = HM.insert qualName (kind, ExternData declaredRoles) (types env) } _ -> internalError "Unsupported role declaration" addTypeSynonym @@ -113,11 +114,11 @@ addTypeSynonym moduleName name args ty kind = do env <- getEnv checkTypeSynonyms ty let qualName = mkQualified_ (ByModuleName moduleName) name - hasSig = qualName `M.member` types env + hasSig = qualName `HM.member` types env unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration TypeSynonymSig name kind - putEnv $ env { types = M.insert qualName (kind, TypeSynonym) (types env) - , typeSynonyms = M.insert qualName (args, ty) (typeSynonyms env) } + putEnv $ env { types = HM.insert qualName (kind, TypeSynonym) (types env) + , typeSynonyms = HM.insert qualName (args, ty) (typeSynonyms env) } valueIsNotDefined :: ModuleName @@ -125,7 +126,7 @@ valueIsNotDefined -> TypeCheckM () valueIsNotDefined moduleName name = do env <- getEnv - case M.lookup (mkQualified_ (ByModuleName moduleName) name) (names env) of + case HM.lookup (mkQualified_ (ByModuleName moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> return () @@ -137,7 +138,7 @@ addValue -> TypeCheckM () addValue moduleName name ty nameKind = do env <- getEnv - putEnv (env { names = M.insert (mkQualified_ (ByModuleName moduleName) name) (ty, nameKind, Defined) (names env) }) + putEnv (env { names = HM.insert (mkQualified_ (ByModuleName moduleName) name) (ty, nameKind, Defined) (names env) }) addTypeClass :: ModuleName @@ -152,11 +153,11 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do env <- getEnv newClass <- mkNewClass let qualName = mapQualified coerceProperName qualifiedClassName - hasSig = qualName `M.member` types env + hasSig = qualName `HM.member` types env unless (hasSig || not (containsForAll kind)) $ do tell . errorMessage $ MissingKindDeclaration ClassSig (disqualify qualName) kind - putEnv $ env { types = M.insert qualName (kind, ExternData (nominalRolesForKind kind)) (types env) - , typeClasses = M.insert qualifiedClassName newClass (typeClasses env) } + putEnv $ env { types = HM.insert qualName (kind, ExternData (nominalRolesForKind kind)) (types env) + , typeClasses = HM.insert qualifiedClassName newClass (typeClasses env) } where classMembers :: [(Ident, SourceType)] classMembers = map toPair ds @@ -168,7 +169,7 @@ addTypeClass _ qualifiedClassName args implies dependencies ds kind = do let ctIsEmpty = null classMembers && all (typeClassIsEmpty . findSuperClass env) implies' pure $ makeTypeClassData args classMembers implies' dependencies ctIsEmpty where - findSuperClass env c = case M.lookup (constraintClass c) (typeClasses env) of + findSuperClass env c = case HM.lookup (constraintClass c) (typeClasses env) of Just tcd -> tcd Nothing -> internalError "Unknown super class in TypeClassDeclaration" @@ -285,7 +286,7 @@ typeCheckAll moduleName = traverse go for_ (zip clss cls_ks) $ \((deps, (sa, pn, _, _, _)), (args', implies', tys', kind)) -> do let qualifiedClassName = mkQualified_ (ByModuleName moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn (fst sa))) $ - not (M.member qualifiedClassName (typeClasses env)) + not (HM.member qualifiedClassName (typeClasses env)) addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind return d where @@ -308,7 +309,7 @@ typeCheckAll moduleName = traverse go warnAndRethrow (addHint (ErrorInKindDeclaration name) . addHint (positionedError ss)) $ do elabTy <- withFreshSubstitution $ checkKindDeclaration moduleName ty env <- getEnv - putEnv $ env { types = M.insert (mkQualified_ (ByModuleName moduleName) name) (elabTy, LocalTypeVariable) (types env) } + putEnv $ env { types = HM.insert (mkQualified_ (ByModuleName moduleName) name) (elabTy, LocalTypeVariable) (types env) } return $ KindDeclaration sa kindFor name elabTy go d@(RoleDeclaration rdd) = do checkRoleDeclaration moduleName rdd @@ -349,7 +350,7 @@ typeCheckAll moduleName = traverse go env <- getEnv let qualName = mkQualified_ (ByModuleName moduleName) name roles = nominalRolesForKind elabKind - putEnv $ env { types = M.insert qualName (elabKind, ExternData roles) (types env) } + putEnv $ env { types = HM.insert qualName (elabKind, ExternData roles) (types env) } return d go d@(ExternDeclaration (ss, _) name ty) = do warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (positionedError ss)) $ do @@ -359,9 +360,9 @@ typeCheckAll moduleName = traverse go ty'' <- varIfUnknown unks ty' pure (ty'', kind) checkTypeKind elabTy kind - case M.lookup (mkQualified_ (ByModuleName moduleName) name) (names env) of + case HM.lookup (mkQualified_ (ByModuleName moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name - Nothing -> putEnv (env { names = M.insert (mkQualified_ (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) }) + Nothing -> putEnv (env { names = HM.insert (mkQualified_ (ByModuleName moduleName) name) (elabTy, External, Defined) (names env) }) return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d @@ -370,7 +371,7 @@ typeCheckAll moduleName = traverse go env <- getEnv let qualifiedClassName = mkQualified_ (ByModuleName moduleName) pn guardWith (errorMessage (DuplicateTypeClass pn ss)) $ - not (M.member qualifiedClassName (typeClasses env)) + not (HM.member qualifiedClassName (typeClasses env)) (args', implies', tys', kind) <- kindOfClass moduleName (sa, pn, args, implies, tys) addTypeClass moduleName qualifiedClassName (fmap Just <$> args') implies' deps tys' kind return d @@ -382,7 +383,7 @@ typeCheckAll moduleName = traverse go flip (traverse_ . traverse_) (typeClassDictionaries env) $ \dictionaries -> guardWith (errorMessage (DuplicateInstance dictName ss)) $ not (HM.member qualifiedDictName dictionaries) - case M.lookup className (typeClasses env) of + case HM.lookup className (typeClasses env) of Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do checkInstanceArity dictName className typeClass tys @@ -614,7 +615,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = getSuperClassExportCheck = do classesToSuperClasses <- gets - ( M.map + ( HM.map ( S.fromList . filter (\(Qualified mn' _) -> mn' == ByModuleName mn) . fmap constraintClass @@ -632,11 +633,11 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = -> S.Set (Qualified (ProperName 'ClassName)) transitiveSuperClassesFor qname = untilSame - (\s -> s <> foldMap (\n -> fromMaybe S.empty (M.lookup n classesToSuperClasses)) s) - (fromMaybe S.empty (M.lookup qname classesToSuperClasses)) + (\s -> s <> foldMap (\n -> fromMaybe S.empty (HM.lookup n classesToSuperClasses)) s) + (fromMaybe S.empty (HM.lookup qname classesToSuperClasses)) superClassesFor qname = - fromMaybe S.empty (M.lookup qname classesToSuperClasses) + fromMaybe S.empty (HM.lookup qname classesToSuperClasses) pure $ checkSuperClassExport superClassesFor transitiveSuperClassesFor moduleClassExports :: S.Set (Qualified (ProperName 'ClassName)) @@ -650,17 +651,17 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = checkMemberExport :: (SourceType -> [DeclarationRef]) -> DeclarationRef -> TypeCheckM () checkMemberExport extract dr@(TypeRef _ name dctors) = do env <- getEnv - for_ (M.lookup (qualify' name) (types env)) $ \(k, _) -> do + for_ (HM.lookup (qualify' name) (types env)) $ \(k, _) -> do -- TODO: remove? -- let findModuleKinds = everythingOnTypes (++) $ \case -- TypeConstructor _ (Qualified (ByModuleName mn') kindName) | mn' == mn -> [kindName] -- _ -> [] checkExport dr (extract k) - for_ (M.lookup (qualify' name) (typeSynonyms env)) $ \(_, ty) -> + for_ (HM.lookup (qualify' name) (typeSynonyms env)) $ \(_, ty) -> checkExport dr (extract ty) for_ dctors $ \dctors' -> for_ dctors' $ \dctor -> - for_ (M.lookup (qualify' dctor) (dataConstructors env)) $ \(_, _, ty, _) -> + for_ (HM.lookup (qualify' dctor) (dataConstructors env)) $ \(_, _, ty, _) -> checkExport dr (extract ty) checkMemberExport extract dr@(ValueRef _ name) = do ty <- lookupVariable (qualify' name) @@ -761,7 +762,7 @@ typeCheckModule modulesExports (Module ss coms mn decls (Just exps)) = | otherwise = do env <- getEnv let dataConstructorNames = fromMaybe [] $ - M.lookup (mkQualified name mn) (types env) >>= getDataConstructorNames . snd + HM.lookup (mkQualified name mn) (types env) >>= getDataConstructorNames . snd missingDataConstructorsNames = dataConstructorNames \\ exportedDataConstructorsNames unless (null missingDataConstructorsNames) $ throwError . errorMessage' ss' $ TransitiveDctorExportError dr missingDataConstructorsNames diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index 2af82a880f..a1982871b5 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -58,7 +58,7 @@ deriveInstance instType className strategy = do TypeClassData{..} <- note (errorMessage . UnknownName $ mapQualified TyClassName className) $ - className `M.lookup` typeClasses env + className `HM.lookup` typeClasses env case strategy of KnownClassStrategy -> let @@ -143,10 +143,10 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs verifySuperclasses :: TypeCheckM () verifySuperclasses = do env <- getEnv - for_ (M.lookup className (typeClasses env)) $ \TypeClassData{ typeClassArguments = args, typeClassSuperclasses = superclasses } -> + for_ (HM.lookup className (typeClasses env)) $ \TypeClassData{ typeClassArguments = args, typeClassSuperclasses = superclasses } -> for_ superclasses $ \Constraint{..} -> do let constraintClass' = qualify (internalError "verifySuperclasses: unknown class module") constraintClass - for_ (M.lookup constraintClass (typeClasses env)) $ \TypeClassData{ typeClassDependencies = deps } -> + for_ (HM.lookup constraintClass (typeClasses env)) $ \TypeClassData{ typeClassDependencies = deps } -> -- We need to check whether the newtype is mentioned, because of classes like MonadWriter -- with its Monoid superclass constraint. when (not (null args) && any ((fst (last args) `elem`) . usedTypeVariables) constraintArgs) $ do @@ -340,11 +340,11 @@ lookupTypeDecl lookupTypeDecl mn typeName = do env <- getEnv note (errorMessage $ CannotFindDerivingType typeName) $ do - (kind, DataType _ args dctors) <- mkQualified_ (ByModuleName mn) typeName `M.lookup` types env + (kind, DataType _ args dctors) <- mkQualified_ (ByModuleName mn) typeName `HM.lookup` types env (kargs, _) <- completeBinderList kind let dtype = do (ctorName, _) <- headMay dctors - (a, _, _, _) <- mkQualified_ (ByModuleName mn) ctorName `M.lookup` dataConstructors env + (a, _, _, _) <- mkQualified_ (ByModuleName mn) ctorName `HM.lookup` dataConstructors env pure a pure (dtype, fst . snd <$> kargs, map (\(v, k, _) -> (v, k)) args, dctors) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 7106e75f6f..21595a7dab 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -256,7 +256,7 @@ entails SolverOptions{..} constraint context hints = , typeClassIsEmpty , typeClassCoveringSets , typeClassMembers - } <- case M.lookup className' classesInScope of + } <- case HM.lookup className' classesInScope of Nothing -> throwError . errorMessage $ UnknownClass className' Just tcd -> pure tcd @@ -871,7 +871,7 @@ newDictionaries -> m [NamedDict] newDictionaries path name (Constraint _ className instanceKinds instanceTy _) = do tcs <- gets (typeClasses . checkEnv) - let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs + let TypeClassData{..} = fromMaybe (internalError "newDictionaries: type class lookup failed") $ HM.lookup className tcs supDicts <- join <$> zipWithM (\(Constraint ann supName supKinds supArgs _) index -> let sub = zip (map fst typeClassArguments) instanceTy in newDictionaries ((supName, index) : path) diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index 1187099720..fcf4155858 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -47,6 +47,7 @@ import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, import Language.PureScript.Roles (Role(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes) import Language.PureScript.Constants.Prim qualified as Prim +import Data.HashMap.Strict qualified as HM -- | State of the given constraints solver. data GivenSolverState = @@ -547,7 +548,7 @@ canonUnsaturatedHigherKindedType -> MaybeT CanonM Canonicalized canonUnsaturatedHigherKindedType env a b | (TypeConstructor _ aTyName, akapps, axs) <- unapplyTypes a - , (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ M.lookup aTyName (types env) + , (ak, _) <- fromMaybe (internalError "canonUnsaturatedHigherKindedType: type lookup failed") $ HM.lookup aTyName (types env) , (aks, _) <- unapplyKinds ak , length axs < length aks = do ak' <- lift $ do @@ -651,7 +652,7 @@ lookupNewtypeConstructor -> [SourceType] -> Maybe ([Text], ProperName 'ConstructorName, SourceType) lookupNewtypeConstructor env qualifiedNewtypeName ks = do - (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- M.lookup qualifiedNewtypeName (types env) + (newtyk, DataType Newtype tvs [(ctorName, [wrappedTy])]) <- HM.lookup qualifiedNewtypeName (types env) let (kvs, _) = fromMaybe (internalError "lookupNewtypeConstructor: unkinded forall binder") $ completeBinderList newtyk instantiatedKinds = zipWith (\(_, (kv, _)) k -> (kv, k)) kvs ks pure (map (\(name, _, _) -> name) tvs, ctorName, replaceAllTypeVars instantiatedKinds wrappedTy) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 0eb16bc4da..7d61eede2b 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -57,6 +57,7 @@ import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScop import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.Types import Language.PureScript.Pretty.Types (prettyPrintType) +import Data.HashMap.Strict qualified as HM generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType generalizeUnknowns unks ty = @@ -166,7 +167,7 @@ inferKind = \tyToInfer -> go = \case ty@(TypeConstructor ann v) -> do env <- getEnv - case M.lookup v (E.types env) of + case HM.lookup v (E.types env) of Nothing -> throwError . errorMessage' (fst ann) . UnknownName . mapQualified TyName $ v Just (kind, E.LocalTypeVariable) -> do @@ -176,7 +177,7 @@ inferKind = \tyToInfer -> pure (ty, kind $> ann) ConstrainedType ann' con@(Constraint ann v _ _ _) ty -> do env <- getEnv - con' <- case M.lookup (coerceProperName `mapQualified` v) (E.types env) of + con' <- case HM.lookup (coerceProperName `mapQualified` v) (E.types env) of Nothing -> throwError . errorMessage' (fst ann) . UnknownName . mapQualified TyClassName $ v Just _ -> @@ -270,7 +271,7 @@ inferAppKind ann (fn, fnKind) arg = case fnKind of cannotApplyTypeToType fn arg where requiresSynonymsToExpand = \case - TypeConstructor _ v -> M.notMember v . E.typeSynonyms <$> getEnv + TypeConstructor _ v -> not . HM.member v . E.typeSynonyms <$> getEnv TypeApp _ l _ -> requiresSynonymsToExpand l KindApp _ l _ -> requiresSynonymsToExpand l _ -> pure True @@ -522,7 +523,7 @@ elaborateKind = \case pure $ E.tyInt $> ann TypeConstructor ann v -> do env <- getEnv - case M.lookup v (E.types env) of + case HM.lookup v (E.types env) of Nothing -> throwError . errorMessage' (fst ann) . UnknownName . mapQualified TyName $ v Just (kind, _) -> @@ -941,7 +942,7 @@ existingSignatureOrFreshKind -> TypeCheckM SourceType existingSignatureOrFreshKind moduleName ss name = do env <- getEnv - case M.lookup (mkQualified_ (ByModuleName moduleName) name) (E.types env) of + case HM.lookup (mkQualified_ (ByModuleName moduleName) name) (E.types env) of Nothing -> freshKind ss Just (kind, _) -> pure kind diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 48f5c65fa1..a662401e4f 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -147,24 +147,24 @@ type Unknown = Int -- | Temporarily bind a collection of names to values bindNames - :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) + :: HM.HashMap (Qualified Ident) (SourceType, NameKind, NameVisibility) -> TypeCheckM a -> TypeCheckM a bindNames newNames action = do orig <- get - modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } } + modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `HM.union` (names . checkEnv $ st) } } a <- action modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } } return a -- | Temporarily bind a collection of names to types bindTypes - :: M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) + :: HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) -> TypeCheckM a -> TypeCheckM a bindTypes newNames action = do orig <- get - modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } } + modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `HM.union` (types . checkEnv $ st) } } a <- action modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } } return a @@ -178,9 +178,9 @@ withScopedTypeVars withScopedTypeVars mn ks ma = do orig <- get forM_ ks $ \(name, _) -> - when (mkQualified_ (ByModuleName mn) (properNameFromString name) `M.member` types (checkEnv orig)) $ + when (mkQualified_ (ByModuleName mn) (properNameFromString name) `HM.member` types (checkEnv orig)) $ tell . errorMessage $ ShadowedTypeVar name - bindTypes (M.fromList (map (\(name, k) -> (mkQualified_ (ByModuleName mn) (properNameFromString name), (k, ScopedTypeVar))) ks)) ma + bindTypes (HM.fromList (map (\(name, k) -> (mkQualified_ (ByModuleName mn) (properNameFromString name), (k, ScopedTypeVar))) ks)) ma withErrorMessageHint :: (MonadState CheckState m, MonadError MultipleErrors m) @@ -256,7 +256,7 @@ bindLocalVariables -> TypeCheckM a -> TypeCheckM a bindLocalVariables bindings = - bindNames (M.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (mkQualified_ (BySourcePos $ spanStart ss) name, (ty, Private, visibility))) + bindNames (HM.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (mkQualified_ (BySourcePos $ spanStart ss) name, (ty, Private, visibility))) -- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables @@ -265,11 +265,11 @@ bindLocalTypeVariables -> TypeCheckM a -> TypeCheckM a bindLocalTypeVariables moduleName bindings = - bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (mkQualified_ (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) + bindTypes (HM.fromList $ flip map bindings $ \(pn, kind) -> (mkQualified_ (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) -- | Update the visibility of all names to Defined makeBindingGroupVisible :: TypeCheckM () -makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) } +makeBindingGroupVisible = modifyEnv $ \e -> e { names = HM.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) } -- | Update the visibility of all names to Defined in the scope of the provided action withBindingGroupVisible :: TypeCheckM a -> TypeCheckM a @@ -289,7 +289,7 @@ lookupVariable -> TypeCheckM SourceType lookupVariable qual = do env <- getEnv - case M.lookup qual (names env) of + case HM.lookup qual (names env) of Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual) Just (ty, _, _) -> return ty @@ -299,7 +299,7 @@ getVisibility -> TypeCheckM NameVisibility getVisibility qual = do env <- getEnv - case M.lookup qual (names env) of + case HM.lookup qual (names env) of Nothing -> throwError . errorMessage $ NameIsUndefined (disqualify qual) Just (_, _, vis) -> return vis @@ -320,7 +320,7 @@ lookupTypeVariable -> TypeCheckM SourceType lookupTypeVariable currentModule (Qualified qb name) = do env <- getEnv - case M.lookup (mkQualified_ qb' name) (types env) of + case HM.lookup (mkQualified_ qb' name) (types env) of Nothing -> throwError . errorMessage $ UndefinedTypeVariable name Just (k, _) -> return k where @@ -336,7 +336,7 @@ getEnv = gets checkEnv getLocalContext :: TypeCheckM Context getLocalContext = do env <- getEnv - return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{}, (ty', _, Defined)) <- M.toList (names env) ] + return [ (ident, ty') | (Qualified (BySourcePos _) ident@Ident{}, (ty', _, Defined)) <- HM.toList (names env) ] -- | Update the @Environment@ putEnv :: Environment -> TypeCheckM () @@ -405,7 +405,7 @@ debugConstraint (Constraint ann clsName kinds args _) = debugType $ foldl (TypeApp ann) (foldl (KindApp ann) (TypeConstructor ann (mapQualified coerceProperName clsName)) kinds) args debugTypes :: Environment -> [String] -debugTypes = go <=< M.toList . types +debugTypes = go <=< HM.toList . types where go (qual, (srcTy, which)) = do let @@ -421,7 +421,7 @@ debugTypes = go <=< M.toList . types pure $ decl <> " " <> unpack name <> " :: " <> init ppTy debugNames :: Environment -> [String] -debugNames = fmap go . M.toList . names +debugNames = fmap go . HM.toList . names where go (qual, (srcTy, _, _)) = do let @@ -430,7 +430,7 @@ debugNames = fmap go . M.toList . names unpack name <> " :: " <> init ppTy debugDataConstructors :: Environment -> [String] -debugDataConstructors = fmap go . M.toList . dataConstructors +debugDataConstructors = fmap go . HM.toList . dataConstructors where go (qual, (_, _, ty, _)) = do let @@ -439,7 +439,7 @@ debugDataConstructors = fmap go . M.toList . dataConstructors unpack name <> " :: " <> init ppTy debugTypeSynonyms :: Environment -> [String] -debugTypeSynonyms = fmap go . M.toList . typeSynonyms +debugTypeSynonyms = fmap go . HM.toList . typeSynonyms where go (qual, (binders, subTy)) = do let @@ -467,7 +467,7 @@ debugTypeClassDictionaries = go . typeClassDictionaries pure $ "dict " <> unpack moduleName <> unpack className' <> " " <> unpack ident' <> " (" <> show (length dicts) <> ")" <> " " <> kds <> " " <> tys debugTypeClasses :: Environment -> [String] -debugTypeClasses = fmap go . M.toList . typeClasses +debugTypeClasses = fmap go . HM.toList . typeClasses where go (className, tc) = do let diff --git a/src/Language/PureScript/TypeChecker/Roles.hs b/src/Language/PureScript/TypeChecker/Roles.hs index cfce31c954..267f9505a2 100644 --- a/src/Language/PureScript/TypeChecker/Roles.hs +++ b/src/Language/PureScript/TypeChecker/Roles.hs @@ -29,6 +29,7 @@ import Language.PureScript.Errors (DataConstructorDeclaration(..), MultipleError import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), Qualified, QualifiedBy(..), mkQualified_) import Language.PureScript.Roles (Role(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), freeTypeVariables, unapplyTypes) +import Data.HashMap.Strict qualified as HM -- | -- A map of a type's formal parameter names to their roles. This type's @@ -46,7 +47,7 @@ instance Monoid RoleMap where mempty = RoleMap M.empty -type RoleEnv = M.Map (Qualified (ProperName 'TypeName)) [Role] +type RoleEnv = HM.HashMap (Qualified (ProperName 'TypeName)) [Role] typeKindRoles :: TypeKind -> Maybe [Role] typeKindRoles = \case @@ -59,7 +60,7 @@ typeKindRoles = \case getRoleEnv :: Environment -> RoleEnv getRoleEnv env = - M.mapMaybe (typeKindRoles . snd) (types env) + HM.mapMaybe (typeKindRoles . snd) (types env) updateRoleEnv :: Qualified (ProperName 'TypeName) @@ -67,10 +68,10 @@ updateRoleEnv -> RoleEnv -> (Any, RoleEnv) updateRoleEnv qualTyName roles' roleEnv = - let roles = fromMaybe (repeat Phantom) $ M.lookup qualTyName roleEnv + let roles = fromMaybe (repeat Phantom) $ HM.lookup qualTyName roleEnv mostRestrictiveRoles = zipWith min roles roles' didRolesChange = any (uncurry (<)) $ zip mostRestrictiveRoles roles - in (Any didRolesChange, M.insert qualTyName mostRestrictiveRoles roleEnv) + in (Any didRolesChange, HM.insert qualTyName mostRestrictiveRoles roleEnv) -- | -- Lookup the roles for a type in the environment. If the type does not have @@ -82,7 +83,7 @@ lookupRoles -> Qualified (ProperName 'TypeName) -> [Role] lookupRoles env tyName = - fromMaybe [] $ M.lookup tyName (types env) >>= typeKindRoles . snd + fromMaybe [] $ HM.lookup tyName (types env) >>= typeKindRoles . snd -- | -- Compares the inferred roles to the explicitly declared roles and ensures @@ -140,13 +141,13 @@ inferDataBindingGroupRoles -> [(Text, Maybe SourceType)] -> [Role] inferDataBindingGroupRoles env moduleName roleDeclarations group = - let declaredRoleEnv = M.fromList $ map (mkQualified_ (ByModuleName moduleName) . rdeclIdent &&& rdeclRoles) roleDeclarations + let declaredRoleEnv = HM.fromList $ map (mkQualified_ (ByModuleName moduleName) . rdeclIdent &&& rdeclRoles) roleDeclarations inferredRoleEnv = getRoleEnv env - initialRoleEnv = declaredRoleEnv `M.union` inferredRoleEnv + initialRoleEnv = declaredRoleEnv `HM.union` inferredRoleEnv inferredRoleEnv' = inferDataBindingGroupRoles' moduleName group initialRoleEnv in \tyName tyArgs -> let qualTyName = mkQualified_ (ByModuleName moduleName) tyName - inferredRoles = M.lookup qualTyName inferredRoleEnv' + inferredRoles = HM.lookup qualTyName inferredRoleEnv' in fromMaybe (Phantom <$ tyArgs) inferredRoles type DataDeclaration = @@ -235,7 +236,7 @@ inferDataDeclarationRoles moduleName (tyName, tyArgs, ctors) roleEnv = -- our parameters is unimportant. TypeConstructor _ t1Name -> let - t1Roles = fromMaybe (repeat Phantom) $ M.lookup t1Name roleEnv + t1Roles = fromMaybe (repeat Phantom) $ HM.lookup t1Name roleEnv k role ti = case role of Nominal -> freeNominals btvs ti diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 9672836d6a..7279e62f61 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -14,6 +14,7 @@ import Prelude import Control.Monad.Error.Class (MonadError(..)) import Data.Maybe (fromMaybe) import Data.Map qualified as M +import Data.HashMap.Strict qualified as HM import Data.Text (Text) import Language.PureScript.Environment (Environment(..), TypeKind) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), SourceSpan, errorMessage') @@ -22,9 +23,9 @@ import Language.PureScript.TypeChecker.Monad (getEnv, TypeCheckM) import Language.PureScript.Types (SourceType, Type(..), completeBinderList, everywhereOnTypesTopDownM, getAnnForType, replaceAllTypeVars) -- | Type synonym information (arguments with kinds, aliased type), indexed by name -type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) +type SynonymMap = HM.HashMap (Qualified (ProperName 'TypeName)) ([(Text, Maybe SourceType)], SourceType) -type KindMap = M.Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) +type KindMap = HM.HashMap (Qualified (ProperName 'TypeName)) (SourceType, TypeKind) replaceAllTypeSynonyms' :: SynonymMap @@ -38,13 +39,13 @@ replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try go :: SourceSpan -> Int -> [SourceType] -> [SourceType] -> SourceType -> Either MultipleErrors (Maybe SourceType) go ss c kargs args (TypeConstructor _ ctor) - | Just (synArgs, body) <- M.lookup ctor syns + | Just (synArgs, body) <- HM.lookup ctor syns , c == length synArgs , kindArgs <- lookupKindArgs ctor , length kargs == length kindArgs = let repl = replaceAllTypeVars (zip (map fst synArgs) args <> zip kindArgs kargs) body in Just <$> try repl - | Just (synArgs, _) <- M.lookup ctor syns + | Just (synArgs, _) <- HM.lookup ctor syns , length synArgs > c = throwError . errorMessage' ss $ PartiallyAppliedSynonym ctor go ss c kargs args (TypeApp _ f arg) = go ss (c + 1) kargs (arg : args) f @@ -52,7 +53,7 @@ replaceAllTypeSynonyms' syns kinds = everywhereOnTypesTopDownM try go _ _ _ _ _ = return Nothing lookupKindArgs :: Qualified (ProperName 'TypeName) -> [Text] - lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< M.lookup ctor kinds + lookupKindArgs ctor = fromMaybe [] $ fmap (fmap (fst . snd) . fst) . completeBinderList . fst =<< HM.lookup ctor kinds -- | Replace fully applied type synonyms replaceAllTypeSynonyms :: SourceType -> TypeCheckM SourceType diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 5bf85bd4be..6e0ae400f4 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -23,6 +23,7 @@ import Language.PureScript.TypeChecker.Synonyms as P import Language.PureScript.Types as P import Control.Monad.Supply qualified as P import Language.PureScript.TypeChecker.Monad qualified as P +import Data.HashMap.Strict qualified as HM.HashMap checkInEnvironment :: Environment @@ -119,17 +120,17 @@ typeSearch -> ([(P.Qualified Text, P.SourceType)], Maybe [(Label, P.SourceType)]) typeSearch unsolved env st type' = let - runTypeSearch :: Map k P.SourceType -> Map k P.SourceType - runTypeSearch = Map.mapMaybe (\ty -> checkSubsume unsolved env st type' ty $> ty) + runTypeSearch :: HM.HashMap k P.SourceType -> HM.HashMap k P.SourceType + runTypeSearch = HM.mapMaybe (\ty -> checkSubsume unsolved env st type' ty $> ty) - matchingNames = runTypeSearch (Map.map (\(ty, _, _) -> ty) (P.names env)) - matchingConstructors = runTypeSearch (Map.map (\(_, _, ty, _) -> ty) (P.dataConstructors env)) + matchingNames = runTypeSearch (HM.map (\(ty, _, _) -> ty) (P.names env)) + matchingConstructors = runTypeSearch (HM.map (\(_, _, ty, _) -> ty) (P.dataConstructors env)) (allLabels, matchingLabels) = accessorSearch unsolved env st type' runPlainIdent (Qualified m (Ident k), v) = Just (Qualified m k, v) runPlainIdent _ = Nothing in ( (first (P.mkQualified_ P.ByNullSourcePos . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) - <> mapMaybe runPlainIdent (Map.toList matchingNames) - <> (first (mapQualified P.runProperName) <$> Map.toList matchingConstructors) + <> mapMaybe runPlainIdent (HM.toList matchingNames) + <> (first (mapQualified P.runProperName) <$> HM.toList matchingConstructors) , if null allLabels then Nothing else Just allLabels) diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index ab2a3bbfd0..28e77eab3d 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -63,6 +63,7 @@ import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, replaceTypeWild import Language.PureScript.Types import Language.PureScript.Label (Label(..)) import Language.PureScript.PSString (PSString) +import Data.HashMap.Strict qualified as HM data BindingGroupType = RecursiveBindingGroup @@ -79,7 +80,7 @@ tvToExpr (TypedValue' c e t) = TypedValue c e t -- | Lookup data about a type class in the @Environment@ lookupTypeClass :: MonadState CheckState TypeCheckM => Qualified (ProperName 'ClassName) -> TypeCheckM TypeClassData lookupTypeClass name = - let findClass = fromMaybe (internalError "entails: type class not found in environment") . M.lookup name + let findClass = fromMaybe (internalError "entails: type class not found in environment") . HM.lookup name in gets (findClass . typeClasses . checkEnv) -- | Infer the types of multiple mutually-recursive values, and return elaborated values including @@ -234,7 +235,7 @@ data SplitBindingGroup = SplitBindingGroup -- ^ The untyped expressions , _splitBindingGroupTyped :: [((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool))] -- ^ The typed expressions, along with their type annotations - , _splitBindingGroupNames :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) + , _splitBindingGroupNames :: HM.HashMap (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ A map containing all expressions and their assigned types (which might be -- fresh unification variables). These will be added to the 'Environment' after -- the binding group is checked, so the value type of the 'Map' is chosen to be @@ -266,7 +267,7 @@ typeDictionaryForBindingGroup moduleName vals = do return ((sai, ty), (sai, (expr, ty))) -- Create the dictionary of all name/type pairs, which will be added to the -- environment during type checking - let dict = M.fromList [ (mkQualified_ (maybe (BySourcePos $ spanStart ss) ByModuleName moduleName) ident, (ty, Private, Undefined)) + let dict = HM.fromList [ (mkQualified_ (maybe (BySourcePos $ spanStart ss) ByModuleName moduleName) ident, (ty, Private, Undefined)) | (((ss, _), ident), ty) <- typedDict <> untypedDict ] return (SplitBindingGroup untyped' typed' dict) @@ -287,7 +288,7 @@ checkTypedBindingGroupElement => ModuleName -> ((SourceAnn, Ident), (Expr, [(Text, SourceType)], SourceType, Bool)) -- ^ The identifier we are trying to define, along with the expression and its type annotation - -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) + -> HM.HashMap (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group -> TypeCheckM ((SourceAnn, Ident), (Expr, SourceType)) checkTypedBindingGroupElement mn (ident, (val, args, ty, checkType)) dict = do @@ -306,7 +307,7 @@ typeForBindingGroupElement => ((SourceAnn, Ident), (Expr, SourceType)) -- ^ The identifier we are trying to define, along with the expression and its assigned type -- (at this point, this should be a unification variable) - -> M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) + -> HM.HashMap (Qualified Ident) (SourceType, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group -> TypeCheckM ((SourceAnn, Ident), (Expr, SourceType)) typeForBindingGroupElement (ident, (val, ty)) dict = do @@ -489,7 +490,7 @@ infer' (Var ss var) = do _ -> return $ TypedValue' True (Var ss var) ty infer' v@(Constructor _ c) = do env <- getEnv - case M.lookup c (dataConstructors env) of + case HM.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage . UnknownName . mapQualified DctorName $ c Just (_, _, ty, _) -> TypedValue' True v <$> (introduceSkolemScope <=< replaceAllTypeSynonyms $ ty) infer' (Case vals binders) = do @@ -585,20 +586,20 @@ inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (Typed TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do ((args, elabTy), kind) <- kindOfWithScopedVars ty checkTypeKind ty kind - let dict = M.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) + let dict = HM.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (elabTy, nameKind, Undefined) ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ elabTy if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return (TypedValue' checkType val elabTy) - bindNames (M.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) + bindNames (HM.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do valTy <- freshTypeWithKind kindType TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do - let dict = M.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) + let dict = HM.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (valTy, nameKind, Undefined) bindNames dict $ infer val warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy' - bindNames (M.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) + bindNames (HM.singleton (mkQualified_ (BySourcePos $ spanStart ss) ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do moduleName <- unsafeCheckCurrentModule @@ -625,7 +626,7 @@ inferBinder val (LiteralBinder _ (BooleanLiteral _)) = unifyTypes val tyBoolean inferBinder val (VarBinder ss name) = return $ M.singleton name (ss, val) inferBinder val (ConstructorBinder ss ctor binders) = do env <- getEnv - case M.lookup ctor (dataConstructors env) of + case HM.lookup ctor (dataConstructors env) of Just (_, _, ty, _) -> do (_, fn) <- instantiatePolyTypeWithUnknowns (internalError "Data constructor types cannot contain constraints") ty fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn @@ -776,7 +777,7 @@ check' val (ForAll ann vis ident mbK ty _) = do -- an undefined type variable that happens to clash with the variable we -- want to skolemize. This can happen due to synonym expansion (see 2542). skVal - | Just _ <- M.lookup (mkQualified_ (byMaybeModuleName mn) (properNameFromString ident)) $ types env = + | Just _ <- HM.lookup (mkQualified_ (byMaybeModuleName mn) (properNameFromString ident)) $ types env = skolemizeTypesInValue ss ident mbK sko scope val | otherwise = val val' <- tvToExpr <$> check skVal sk @@ -885,7 +886,7 @@ check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val return $ TypedValue' True (Accessor prop val') ty check' v@(Constructor _ c) ty = do env <- getEnv - case M.lookup c (dataConstructors env) of + case HM.lookup c (dataConstructors env) of Nothing -> throwError . errorMessage . UnknownName . mapQualified DctorName $ c Just (_, _, ty1, _) -> do repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1 diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs index 3e702786a0..bd35b002c1 100644 --- a/tests/TestPrimDocs.hs +++ b/tests/TestPrimDocs.hs @@ -5,7 +5,7 @@ import Prelude import Data.List (sort) import Control.Exception (evaluate) import Control.DeepSeq (force) -import Data.Map qualified as Map +import Data.HashMap.Strict qualified as HM import Data.Text qualified as Text import Language.PureScript qualified as P import Language.PureScript.Docs qualified as D @@ -21,7 +21,7 @@ spec = do it "all Prim modules are fully documented" $ do let actualPrimNames = -- note that prim type classes are listed in P.primTypes - filter (not . Text.any (== '$')) . map (P.runProperName . P.disqualify . fst) $ Map.toList + filter (not . Text.any (== '$')) . map (P.runProperName . P.disqualify . fst) $ HM.toList ( P.primTypes <> P.primBooleanTypes <> P.primCoerceTypes <> From f69b497f3453d4d835a2e45609ed5009a2f23354 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Mon, 19 May 2025 23:54:18 +0000 Subject: [PATCH 12/19] Int map for unification --- src/Language/PureScript/Interner.hs | 2 + src/Language/PureScript/Names.hs | 13 ++++-- src/Language/PureScript/TypeChecker/Monad.hs | 5 ++- src/Language/PureScript/TypeChecker/Unify.hs | 10 ++++- src/Language/PureScript/Types.hs | 42 ++++++++++++++++---- 5 files changed, 57 insertions(+), 15 deletions(-) diff --git a/src/Language/PureScript/Interner.hs b/src/Language/PureScript/Interner.hs index b230f63d32..068f0e5995 100644 --- a/src/Language/PureScript/Interner.hs +++ b/src/Language/PureScript/Interner.hs @@ -94,8 +94,10 @@ instance Ord a => Ord (HashCons a) where {-# INLINE compare #-} instance Eq a => Hashable (HashCons a) where + hash (HashConsC h _) = h hashWithSalt salt (HashConsC h _) = hashWithSalt salt h {-# INLINE hashWithSalt #-} + {-# INLINE hash #-} -- Compare the values in the IORefs with the given comparator, and if the result -- indicates that they are equal, replace one with the other, preferring the one diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 926cc13c54..20f5296846 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -24,7 +24,7 @@ import Data.Text qualified as T import Data.Int (Int64) import Language.PureScript.AST.SourcePos (SourcePos, pattern SourcePos) import Language.PureScript.Interner (HashCons, hashCons, unHashCons) -import Data.Hashable (Hashable) +import Data.Hashable (Hashable (..)) -- | A sum of the possible name types, useful for error and lint messages. data Name @@ -210,7 +210,6 @@ coerceProperName = properNameFromString . runProperName -- newtype ModuleName = ModuleName (HashCons Text) deriving (Eq, Generic) - deriving newtype (Hashable) instance Show ModuleName where show (ModuleName i) = T.unpack $ unHashCons i @@ -222,6 +221,10 @@ instance Serialise ModuleName where encode (ModuleName i) = encode (unHashCons i) decode = ModuleName . hashCons <$> decode +instance Hashable ModuleName where + hash (ModuleName i) = hash i + hashWithSalt s (ModuleName i) = hashWithSalt s i + instance NFData ModuleName runModuleName :: ModuleName -> Text @@ -268,7 +271,7 @@ instance (Serialise a) => Serialise (Qualified' a) newtype Qualified a = QualifiedCons (HashCons (Qualified' a)) deriving (Show, Eq, Generic) - deriving newtype (Hashable, Ord) -- TODO: ORD? + deriving newtype (Ord) -- TODO: ORD? instance (NFData a) => NFData (Qualified a) @@ -276,6 +279,10 @@ instance (Serialise a, Hashable a) => Serialise (Qualified a) where encode (QualifiedCons q) = encode (unHashCons q) decode = QualifiedCons . hashCons <$> decode +instance (Hashable a) => Hashable (Qualified a) where + hash (QualifiedCons q) = hash q + hashWithSalt s (QualifiedCons q) = hashWithSalt s q + infixl 4 `mapQualified` mapQualified :: Hashable b => (a -> b) -> Qualified a -> Qualified b diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index a662401e4f..3444b66d76 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -38,6 +38,7 @@ import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Control.Monad.Identity (Identity(runIdentity)) import Control.Monad (forM_, when, join, (<=<), guard) +import Data.IntSet (IntSet) newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors (SW.Writer MultipleErrors))) a } deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) @@ -135,12 +136,12 @@ data CheckState = CheckState , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName)) -- ^ Newtype constructors imports required to solve Coercible constraints. -- We have to keep track of them so that we don't emit unused import warnings. - , unificationCache :: HS.HashSet (SourceType, SourceType) + , unificationCache :: IntSet } -- | Create an empty @CheckState@ emptyCheckState :: Environment -> CheckState -emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty HS.empty +emptyCheckState env = CheckState env 0 0 0 Nothing [] emptySubstitution [] mempty mempty -- | Unification variables type Unknown = Int diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 9f3bef1b01..0cbb99493e 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -34,6 +34,8 @@ import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown) import Data.HashSet qualified as HS +import Data.IntSet qualified as IntSet +import Data.Hashable (hash) -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible. freshType :: TypeCheckM SourceType @@ -114,8 +116,12 @@ unifyTypes t1 t2 = do where unifyTypes'' t1' t2'= do cache <- gets unificationCache - unless (HS.member (t1', t2') cache) $ do - modify $ \st -> st { unificationCache = HS.insert (t1', t2') cache } + let h1 = hash t1' + h2 = hash t2' + h3 = hash (h1, h2) + h4 = hash (h2, h1) + unless (IntSet.member h3 cache || IntSet.member h4 cache) $ do + modify $ \st -> st { unificationCache = IntSet.insert h3 $ IntSet.insert h4 cache } unifyTypes' t1' t2' unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 0da9167d02..259b52555c 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -28,7 +28,7 @@ import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Names (OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, coerceProperName, mapQualified) import Language.PureScript.Label (Label) import Language.PureScript.PSString (PSString) -import Data.Hashable (Hashable (hashWithSalt)) +import Data.Hashable (Hashable (hashWithSalt, hash)) type SourceType = Type SourceAnn type SourceConstraint = Constraint SourceAnn @@ -120,7 +120,10 @@ instance NFData a => NFData (Type a) instance Serialise a => Serialise (Type a) instance Hashable (Type a) where - hashWithSalt = hashType + hash = hashType + hashWithSalt = hashWithSaltType + {-# INLINE hash #-} + {-# INLINE hashWithSalt #-} srcTUnknown :: Int -> SourceType srcTUnknown = TUnknown NullSourceAnn @@ -821,15 +824,16 @@ eqType (KindedType _ a b) (KindedType _ a' b') = eqType a a' && eqType b b' eqType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = eqType a a' && eqType b b' && eqType c c' eqType (ParensInType _ a) (ParensInType _ a') = eqType a a' eqType _ _ = False +{-# INLINE eqType #-} eqMaybeType :: Maybe (Type a) -> Maybe (Type b) -> Bool eqMaybeType (Just a) (Just b) = eqType a b eqMaybeType Nothing Nothing = True eqMaybeType _ _ = False -infixl 0 `hashType` -hashType :: Int -> Type a -> Int -hashType s = \case +infixl 0 `hashWithSaltType` +hashWithSaltType :: Int -> Type a -> Int +hashWithSaltType s = \case (TUnknown _ a) -> hashWithSalt s a (TypeVar _ a) -> hashWithSalt s a (TypeLevelString _ a) -> hashWithSalt s a @@ -837,11 +841,11 @@ hashType s = \case (TypeWildcard _ a) -> hashWithSalt s a (TypeConstructor _ a) -> hashWithSalt s a (TypeOp _ a) -> hashWithSalt s a - (TypeApp _ a b) -> s `hashType` a `hashType` b - (KindApp _ a b) -> s `hashType` a `hashType` b + (TypeApp _ a b) -> s `hashWithSalt` a `hashWithSalt` b + (KindApp _ a b) -> s `hashWithSalt` a `hashWithSalt` b (ForAll _ _ a b c d) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d - (ConstrainedType _ a b) -> s `hashWithSalt` a `hashType` b + (ConstrainedType _ a b) -> s `hashWithSalt` a `hashWithSalt` b (Skolem _ a b c d) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d (REmpty _) -> hashWithSalt s ("REmpty" :: Text) (RCons _ a b c) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c @@ -849,6 +853,27 @@ hashType s = \case (BinaryNoParensType _ a b c) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c (ParensInType _ a) -> hashWithSalt s a +hashType :: Type a -> Int +hashType = \case + (TUnknown _ a) -> hash a + (TypeVar _ a) -> hash a + (TypeLevelString _ a) -> hash a + (TypeLevelInt _ a) -> hash a + (TypeWildcard _ a) -> hash a + (TypeConstructor _ a) -> hash a + (TypeOp _ a) -> hash a + (TypeApp _ a b) -> hash (a, b) + (KindApp _ a b) -> hash (a, b) + (ForAll _ _ a b c d) -> + hash (a, b, c, d) + (ConstrainedType _ a b) -> hash (a, b) + (Skolem _ a b c d) -> hash (a, b, c, d) + (REmpty _) -> hash ("REmpty" :: Text) + (RCons _ a b c) -> hash (a, b, c) + (KindedType _ a b) -> hash (a, b) + (BinaryNoParensType _ a b c) -> hash (a, b, c) + (ParensInType _ a) -> hash a +{-# INLINE hashType #-} compareType :: Type a -> Type b -> Ordering compareType (TUnknown _ a) (TUnknown _ a') = compare a a' @@ -890,6 +915,7 @@ compareType typ typ' = orderOf BinaryNoParensType{} = 15 orderOf ParensInType{} = 16 +{-# INLINE compareType #-} compareMaybeType :: Maybe (Type a) -> Maybe (Type b) -> Ordering compareMaybeType (Just a) (Just b) = compareType a b From 7bc51cd47d60c032dcada9c6f801ea977516ace7 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Tue, 20 May 2025 13:54:05 +0000 Subject: [PATCH 13/19] Optimize occurs check --- src/Language/PureScript/TypeChecker/Kinds.hs | 52 +++++++++++--------- src/Language/PureScript/TypeChecker/Unify.hs | 45 +++++++++-------- src/Language/PureScript/Types.hs | 25 +--------- 3 files changed, 54 insertions(+), 68 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 7d61eede2b..83ea0cd497 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -41,7 +41,6 @@ import Data.Function (on) import Data.Functor (($>)) import Data.IntSet qualified as IS import Data.List (nubBy, sortOn, (\\)) -import Data.Map qualified as M import Data.IntMap.Lazy qualified as IM import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) @@ -51,7 +50,7 @@ import Data.Traversable (for) import Language.PureScript.Crash (HasCallStack, internalError) import Language.PureScript.Environment qualified as E import Language.PureScript.Errors -import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), coerceProperName, mkQualified, runProperName, properNameFromString, mkQualified_, mapQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, ModuleName, Name(..), ProperName(..), ProperNameType(..), Qualified, QualifiedBy(..), coerceProperName, mkQualified, runProperName, properNameFromString, mkQualified_, mapQualified) import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, bindLocalTypeVariables, debugType, getEnv, lookupTypeVariable, unsafeCheckCurrentModule, withErrorMessageHint, withFreshSubstitution, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScope, skolemize) import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) @@ -629,7 +628,7 @@ type DataDeclarationResult = ) kindOfData - :: + :: ModuleName -> DataDeclarationArgs -> TypeCheckM DataDeclarationResult @@ -637,7 +636,7 @@ kindOfData moduleName dataDecl = head . (^. _2) <$> kindsOfAll moduleName [] [dataDecl] [] inferDataDeclaration - :: + :: ModuleName -> DataDeclarationArgs -> TypeCheckM [(DataConstructorDeclaration, SourceType)] @@ -657,7 +656,7 @@ inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do fmap (fmap (addVisibility visibility . mkForAll ctorBinders)) . inferDataConstructor tyCtor' inferDataConstructor - :: + :: SourceType -> DataConstructorDeclaration -> TypeCheckM (DataConstructorDeclaration, SourceType) @@ -681,7 +680,7 @@ type TypeDeclarationResult = ) kindOfTypeSynonym - :: + :: ModuleName -> TypeDeclarationArgs -> TypeCheckM TypeDeclarationResult @@ -689,7 +688,7 @@ kindOfTypeSynonym moduleName typeDecl = head . (^. _1) <$> kindsOfAll moduleName [typeDecl] [] [] inferTypeSynonym - :: + :: ModuleName -> TypeDeclarationArgs -> TypeCheckM SourceType @@ -711,7 +710,7 @@ inferTypeSynonym moduleName (ann, tyName, tyArgs, tyBody) = do -- | ill-scoped. We require that users explicitly generalize this kind -- | in such a case. checkQuantification - :: + :: SourceType -> TypeCheckM () checkQuantification = @@ -738,7 +737,7 @@ checkQuantification = elem karg $ freeTypeVariables k checkVisibleTypeQuantification - :: + :: SourceType -> TypeCheckM () checkVisibleTypeQuantification = @@ -755,7 +754,7 @@ checkVisibleTypeQuantification = -- | implicitly generalize unknowns, such as on the right-hand-side of -- | a type synonym, or in arguments to data constructors. checkTypeQuantification - :: + :: SourceType -> TypeCheckM () checkTypeQuantification = @@ -798,7 +797,7 @@ type ClassDeclarationResult = ) kindOfClass - :: + :: ModuleName -> ClassDeclarationArgs -> TypeCheckM ClassDeclarationResult @@ -806,7 +805,7 @@ kindOfClass moduleName clsDecl = head . (^. _3) <$> kindsOfAll moduleName [] [] [clsDecl] inferClassDeclaration - :: + :: ModuleName -> ClassDeclarationArgs -> TypeCheckM ([(Text, SourceType)], [SourceConstraint], [Declaration]) @@ -822,7 +821,7 @@ inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = <*> for decls checkClassMemberDeclaration checkClassMemberDeclaration - :: + :: Declaration -> TypeCheckM Declaration checkClassMemberDeclaration = \case @@ -831,7 +830,7 @@ checkClassMemberDeclaration = \case _ -> internalError "Invalid class member declaration" applyClassMemberDeclaration - :: + :: Declaration -> TypeCheckM Declaration applyClassMemberDeclaration = \case @@ -847,7 +846,7 @@ mapTypeDeclaration f = \case other checkConstraint - :: + :: SourceConstraint -> TypeCheckM SourceConstraint checkConstraint (Constraint ann clsName kinds args dat) = do @@ -856,7 +855,7 @@ checkConstraint (Constraint ann clsName kinds args dat) = do pure $ Constraint ann clsName kinds' args' dat applyConstraint - :: + :: SourceConstraint -> TypeCheckM SourceConstraint applyConstraint (Constraint ann clsName kinds args dat) = do @@ -879,7 +878,7 @@ type InstanceDeclarationResult = ) checkInstanceDeclaration - :: + :: ModuleName -> InstanceDeclarationArgs -> TypeCheckM InstanceDeclarationResult @@ -900,7 +899,7 @@ checkInstanceDeclaration moduleName (ann, constraints, clsName, args) = do pure (allConstraints, allKinds, allArgs, varKinds) checkKindDeclaration - :: + :: ModuleName -> SourceType -> TypeCheckM SourceType @@ -929,13 +928,18 @@ checkKindDeclaration _ ty = do pure $ ForAll a' vis v'' k' ty'' sc' other -> pure other - checkValidKind = everywhereOnTypesM $ \case - ty'@(ConstrainedType ann _ _) -> - throwError . errorMessage' (fst ann) $ UnsupportedTypeInKind ty' - other -> pure other + checkValidKind :: SourceType -> TypeCheckM SourceType + checkValidKind = (\case + Left err -> throwError err + Right v -> pure v + ) . everywhereOnTypesM (\case + ty'@(ConstrainedType ann _ _) -> + throwError . errorMessage' (fst ann) $ UnsupportedTypeInKind ty' + other -> pure other + ) existingSignatureOrFreshKind - :: + :: ModuleName -> SourceSpan -> ProperName 'TypeName @@ -947,7 +951,7 @@ existingSignatureOrFreshKind moduleName ss name = do Just (kind, _) -> pure kind kindsOfAll - :: + :: ModuleName -> [TypeDeclarationArgs] -> [DataDeclarationArgs] diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 0cbb99493e..2607b2faf6 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -95,9 +95,13 @@ substituteType sub = everywhereOnTypes go -- | Make sure that an unknown does not occur in a type occursCheck :: Int -> SourceType -> TypeCheckM () occursCheck _ TUnknown{} = return () -occursCheck u t = void $ everywhereOnTypesM go t +occursCheck u t = void $ do + let result = everywhereOnTypesM go t + case result of + Nothing -> throwError . errorMessage . InfiniteType $ t + _ -> return () where - go (TUnknown _ u') | u == u' = throwError . errorMessage . InfiniteType $ t + go (TUnknown _ u') | u == u' = Nothing go other = return other -- | Compute a list of all unknowns appearing in a type @@ -112,17 +116,16 @@ unknownsInType t = everythingOnTypes (.) go t [] unifyTypes :: SourceType -> SourceType -> TypeCheckM () unifyTypes t1 t2 = do sub <- gets checkSubstitution - withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes'' (substituteType sub t1) (substituteType sub t2) + withErrorMessageHint (ErrorUnifyingTypes t1 t2) $ unifyTypes' (substituteType sub t1) (substituteType sub t2) where - unifyTypes'' t1' t2'= do + withCache t1' t2' uf = do cache <- gets unificationCache let h1 = hash t1' h2 = hash t2' - h3 = hash (h1, h2) - h4 = hash (h2, h1) - unless (IntSet.member h3 cache || IntSet.member h4 cache) $ do - modify $ \st -> st { unificationCache = IntSet.insert h3 $ IntSet.insert h4 cache } - unifyTypes' t1' t2' + h3 = hash $ if h1 > h2 then (h1, h2) else (h2, h1) + unless (IntSet.member h3 cache) $ do + modify $ \st -> st { unificationCache = IntSet.insert h3 cache } + uf unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t unifyTypes' t (TUnknown _ u) = solveType u t @@ -139,32 +142,32 @@ unifyTypes t1 t2 = do let sk = skolemize ann ident mbK sko sc ty1 sk `unifyTypes` ty2 unifyTypes' ForAll{} _ = internalError "unifyTypes: unspecified skolem scope" - unifyTypes' ty f@ForAll{} = f `unifyTypes` ty + unifyTypes' ty f@ForAll{} = withCache ty f $ f `unifyTypes` ty unifyTypes' (TypeVar _ v1) (TypeVar _ v2) | v1 == v2 = return () unifyTypes' ty1@(TypeConstructor _ c1) ty2@(TypeConstructor _ c2) = guardWith (errorMessage (TypesDoNotUnify ty1 ty2)) (c1 == c2) unifyTypes' (TypeLevelString _ s1) (TypeLevelString _ s2) | s1 == s2 = return () unifyTypes' (TypeLevelInt _ n1) (TypeLevelInt _ n2) | n1 == n2 = return () - unifyTypes' (TypeApp _ t3 t4) (TypeApp _ t5 t6) = do + unifyTypes' t1'@(TypeApp _ t3 t4) t2'@(TypeApp _ t5 t6) = withCache t1' t2' $ do t3 `unifyTypes` t5 t4 `unifyTypes` t6 - unifyTypes' (KindApp _ t3 t4) (KindApp _ t5 t6) = do + unifyTypes' t1'@(KindApp _ t3 t4) t2'@(KindApp _ t5 t6) = withCache t1' t2' $ do t3 `unifyKinds'` t5 t4 `unifyTypes` t6 unifyTypes' (Skolem _ _ _ s1 _) (Skolem _ _ _ s2 _) | s1 == s2 = return () - unifyTypes' (KindedType _ ty1 _) ty2 = ty1 `unifyTypes` ty2 - unifyTypes' ty1 (KindedType _ ty2 _) = ty1 `unifyTypes` ty2 - unifyTypes' r1@RCons{} r2 = unifyRows r1 r2 - unifyTypes' r1 r2@RCons{} = unifyRows r1 r2 - unifyTypes' r1@REmptyKinded{} r2 = unifyRows r1 r2 - unifyTypes' r1 r2@REmptyKinded{} = unifyRows r1 r2 - unifyTypes' (ConstrainedType _ c1 ty1) (ConstrainedType _ c2 ty2) - | constraintClass c1 == constraintClass c2 && constraintData c1 == constraintData c2 = do + unifyTypes' (KindedType _ ty1 _) ty2 = withCache ty1 ty2 $ ty1 `unifyTypes` ty2 + unifyTypes' ty1 (KindedType _ ty2 _) = withCache ty1 ty2 $ ty1 `unifyTypes` ty2 + unifyTypes' r1@RCons{} r2 = withCache r1 r2 $ unifyRows r1 r2 + unifyTypes' r1 r2@RCons{} = withCache r1 r2 $ unifyRows r1 r2 + unifyTypes' r1@REmptyKinded{} r2 = withCache r1 r2 $ unifyRows r1 r2 + unifyTypes' r1 r2@REmptyKinded{} = withCache r1 r2 $ unifyRows r1 r2 + unifyTypes' t1'@(ConstrainedType _ c1 ty1) t2'@(ConstrainedType _ c2 ty2) + | constraintClass c1 == constraintClass c2 && constraintData c1 == constraintData c2 = withCache t1' t2' $ do traverse_ (uncurry unifyTypes) (constraintArgs c1 `zip` constraintArgs c2) ty1 `unifyTypes` ty2 unifyTypes' ty1@ConstrainedType{} ty2 = throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2 - unifyTypes' t3 t4@ConstrainedType{} = unifyTypes' t4 t3 + unifyTypes' t3 t4@ConstrainedType{} = withCache t3 t4 $ unifyTypes' t4 t3 unifyTypes' t3 t4 = throwError . errorMessage $ TypesDoNotUnify t3 t4 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 259b52555c..73aa6871ec 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -121,8 +121,8 @@ instance Serialise a => Serialise (Type a) instance Hashable (Type a) where hash = hashType - hashWithSalt = hashWithSaltType {-# INLINE hash #-} + hashWithSalt s t = hashWithSalt s (hashType t) {-# INLINE hashWithSalt #-} srcTUnknown :: Int -> SourceType @@ -729,6 +729,7 @@ everywhereOnTypesM f = go where go other = f other {-# INLINE everywhereOnTypesM #-} + everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a) everywhereOnTypesTopDownM f = go <=< f where go (TypeApp ann t1 t2) = TypeApp ann <$> (f t1 >>= go) <*> (f t2 >>= go) @@ -831,28 +832,6 @@ eqMaybeType (Just a) (Just b) = eqType a b eqMaybeType Nothing Nothing = True eqMaybeType _ _ = False -infixl 0 `hashWithSaltType` -hashWithSaltType :: Int -> Type a -> Int -hashWithSaltType s = \case - (TUnknown _ a) -> hashWithSalt s a - (TypeVar _ a) -> hashWithSalt s a - (TypeLevelString _ a) -> hashWithSalt s a - (TypeLevelInt _ a) -> hashWithSalt s a - (TypeWildcard _ a) -> hashWithSalt s a - (TypeConstructor _ a) -> hashWithSalt s a - (TypeOp _ a) -> hashWithSalt s a - (TypeApp _ a b) -> s `hashWithSalt` a `hashWithSalt` b - (KindApp _ a b) -> s `hashWithSalt` a `hashWithSalt` b - (ForAll _ _ a b c d) -> - s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d - (ConstrainedType _ a b) -> s `hashWithSalt` a `hashWithSalt` b - (Skolem _ a b c d) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c `hashWithSalt` d - (REmpty _) -> hashWithSalt s ("REmpty" :: Text) - (RCons _ a b c) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c - (KindedType _ a b) -> s `hashWithSalt` a `hashWithSalt` b - (BinaryNoParensType _ a b c) -> s `hashWithSalt` a `hashWithSalt` b `hashWithSalt` c - (ParensInType _ a) -> hashWithSalt s a - hashType :: Type a -> Int hashType = \case (TUnknown _ a) -> hash a From 9550a4c43448885ae999a527979b45b43f8daf6c Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Tue, 27 May 2025 11:07:31 +0000 Subject: [PATCH 14/19] Use Hashed and HashSet instead of IntMap to address hash conflicts --- src/Language/PureScript/TypeChecker/Monad.hs | 4 ++-- src/Language/PureScript/TypeChecker/Unify.hs | 8 ++++---- src/Language/PureScript/Types.hs | 12 ++++++++++++ 3 files changed, 18 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 3444b66d76..ac2212b3f8 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -26,7 +26,7 @@ import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperN import Language.PureScript.Pretty.Types (prettyPrintType) import Language.PureScript.Pretty.Values (prettyPrintValue) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) -import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar) +import Language.PureScript.Types (Constraint(..), SourceType, Type(..), srcKindedType, srcTypeVar, Hashed) import Text.PrettyPrint.Boxes (render) import Control.Monad.Supply (SupplyT (unSupplyT)) import Control.Monad.Supply.Class (MonadSupply) @@ -136,7 +136,7 @@ data CheckState = CheckState , checkConstructorImportsForCoercible :: S.Set (ModuleName, Qualified (ProperName 'ConstructorName)) -- ^ Newtype constructors imports required to solve Coercible constraints. -- We have to keep track of them so that we don't emit unused import warnings. - , unificationCache :: IntSet + , unificationCache :: HS.HashSet (Hashed (SourceType, SourceType)) } -- | Create an empty @CheckState@ diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 2607b2faf6..a1647610ee 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -32,7 +32,7 @@ import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, unifyKinds') import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) -import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown) +import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown, Hashed(..)) import Data.HashSet qualified as HS import Data.IntSet qualified as IntSet import Data.Hashable (hash) @@ -122,9 +122,9 @@ unifyTypes t1 t2 = do cache <- gets unificationCache let h1 = hash t1' h2 = hash t2' - h3 = hash $ if h1 > h2 then (h1, h2) else (h2, h1) - unless (IntSet.member h3 cache) $ do - modify $ \st -> st { unificationCache = IntSet.insert h3 cache } + hashed :: (Hashed (SourceType, SourceType)) = if h1 > h2 then Hashed (hash (h1, h2)) (t1', t2') else Hashed (hash (h2, h1)) (t2', t1') + unless (HS.member hashed cache) $ do + modify $ \st -> st { unificationCache = HS.insert hashed cache } uf unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return () unifyTypes' (TUnknown _ u) t = solveType u t diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index 73aa6871ec..a1f309fec2 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -917,3 +917,15 @@ eqConstraint (Constraint _ a b c d) (Constraint _ a' b' c' d') = a == a' && and compareConstraint :: Constraint a -> Constraint b -> Ordering compareConstraint (Constraint _ a b c d) (Constraint _ a' b' c' d') = compare a a' <> fold (zipWith compareType b b') <> fold (zipWith compareType c c') <> compare d d' + +-- | The type is used to optimize unification cache lookups, by reducing the potentially expensive hashing of a nested +-- Type +data Hashed a = Hashed { hashValue :: Int, value :: a } + +instance Eq a => Eq (Hashed a) where + (==) (Hashed hashValue value) (Hashed hashValue' value') = + hashValue == hashValue' && value == value' + +instance Eq a => Hashable (Hashed a) where + hashWithSalt s (Hashed hashValue _) = s `hashWithSalt` hashValue + hash (Hashed hashValue _) = hashValue From a090ddb676be5a3e27ce5760a9e5ef2eeec6270a Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Tue, 27 May 2025 11:51:56 +0000 Subject: [PATCH 15/19] Cleanup warnings --- purescript.cabal | 1 - src/Language/PureScript/AST/Declarations.hs | 6 ++-- src/Language/PureScript/AST/Exported.hs | 2 +- src/Language/PureScript/AST/Utils.hs | 10 +++---- src/Language/PureScript/CodeGen/JS.hs | 4 +-- src/Language/PureScript/Constants/Libs.hs | 2 +- src/Language/PureScript/Constants/TH.hs | 2 +- src/Language/PureScript/CoreFn/CSE.hs | 4 +-- src/Language/PureScript/CoreFn/Desugar.hs | 10 +++---- src/Language/PureScript/CoreFn/FromJSON.hs | 8 +++--- src/Language/PureScript/CoreFn/Laziness.hs | 8 +++--- src/Language/PureScript/CoreFn/ToJSON.hs | 4 +-- src/Language/PureScript/Docs/Convert.hs | 3 +- src/Language/PureScript/Docs/Prim.hs | 3 +- .../PureScript/Docs/RenderedCode/Types.hs | 8 +++--- .../PureScript/Interactive/Printer.hs | 5 ++-- src/Language/PureScript/Interner.hs | 8 +++--- src/Language/PureScript/Linter/Exhaustive.hs | 3 +- src/Language/PureScript/Linter/Imports.hs | 1 - src/Language/PureScript/Make/ExternsDiff.hs | 2 +- src/Language/PureScript/Names.hs | 24 ++++++++-------- src/Language/PureScript/Sugar/Names.hs | 14 +++++----- src/Language/PureScript/Sugar/Names/Env.hs | 6 ++-- .../PureScript/Sugar/Names/Exports.hs | 5 ++-- .../PureScript/Sugar/Names/Imports.hs | 2 +- src/Language/PureScript/Sugar/Operators.hs | 28 +++++++++---------- .../PureScript/Sugar/Operators/Binders.hs | 2 +- .../PureScript/Sugar/Operators/Expr.hs | 2 +- .../PureScript/Sugar/Operators/Types.hs | 2 +- src/Language/PureScript/Sugar/TypeClasses.hs | 11 ++++---- .../PureScript/TypeChecker/Deriving.hs | 13 ++++----- .../PureScript/TypeChecker/Entailment.hs | 8 +++--- .../TypeChecker/Entailment/Coercible.hs | 6 ++-- src/Language/PureScript/TypeChecker/Monad.hs | 13 ++++----- .../PureScript/TypeChecker/Synonyms.hs | 1 - .../PureScript/TypeChecker/TypeSearch.hs | 2 -- src/Language/PureScript/TypeChecker/Unify.hs | 5 ++-- tests/TestAst.hs | 2 +- 38 files changed, 113 insertions(+), 127 deletions(-) diff --git a/purescript.cabal b/purescript.cabal index aaf9f4b54f..7c1fcde458 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -169,7 +169,6 @@ common defaults containers >=0.6.5.1 && <0.7, unordered-containers, hashable, - random, cryptonite ==0.30.*, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index be7d4c003b..21d8626f8e 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -26,7 +26,7 @@ import Language.PureScript.AST.Declarations.ChainId (ChainId) import Language.PureScript.Types (SourceConstraint, SourceType) import Language.PureScript.PSString (PSString) import Language.PureScript.Label (Label) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), toMaybeModuleName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), Qualified, pattern Qualified, QualifiedBy(..), toMaybeModuleName) import Language.PureScript.Roles (Role) import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Comments (Comment) @@ -161,8 +161,8 @@ importPrim = let primModName = C.M_Prim in - addDefaultImport (mkQualified_ (ByModuleName primModName) primModName) - . addDefaultImport (mkQualified_ ByNullSourcePos primModName) + addDefaultImport (Qualified (ByModuleName primModName) primModName) + . addDefaultImport (Qualified ByNullSourcePos primModName) data NameSource = UserNamed | CompilerNamed deriving (Eq, Show, Generic, NFData, Serialise) diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index 97778ee101..e3a011f239 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -90,7 +90,7 @@ filterInstances mn (Just exps) = | otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs -- Check that a qualified name is qualified for a different module - checkQual :: (Show a, Hashable a) => Qualified a -> Bool + checkQual :: (Hashable a) => Qualified a -> Bool checkQual q = isQualified q && not (isQualifiedWith mn q) typeName :: DeclarationRef -> Maybe (ProperName 'TypeName) diff --git a/src/Language/PureScript/AST/Utils.hs b/src/Language/PureScript/AST/Utils.hs index ff560a03ce..a93413122b 100644 --- a/src/Language/PureScript/AST/Utils.hs +++ b/src/Language/PureScript/AST/Utils.hs @@ -3,7 +3,7 @@ module Language.PureScript.AST.Utils where import Protolude import Language.PureScript.AST (Binder(..), CaseAlternative, Expr(..), GuardedExpr, Literal, pattern MkUnguarded, nullSourceSpan) -import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), byMaybeModuleName, mkQualified_) +import Language.PureScript.Names (Ident, ModuleName, ProperName, ProperNameType(..), pattern Qualified, QualifiedBy(..), byMaybeModuleName, Qualified) import Language.PureScript.Types (SourceType, Type(..)) lam :: Ident -> Expr -> Expr @@ -19,7 +19,7 @@ mkRef :: Qualified Ident -> Expr mkRef = Var nullSourceSpan mkVarMn :: Maybe ModuleName -> Ident -> Expr -mkVarMn mn = mkRef . mkQualified_ (byMaybeModuleName mn) +mkVarMn mn = mkRef . Qualified (byMaybeModuleName mn) mkVar :: Ident -> Expr mkVar = mkVarMn Nothing @@ -31,10 +31,10 @@ mkLit :: Literal Expr -> Expr mkLit = Literal nullSourceSpan mkCtor :: ModuleName -> ProperName 'ConstructorName -> Expr -mkCtor mn name = Constructor nullSourceSpan (mkQualified_ (ByModuleName mn) name) +mkCtor mn name = Constructor nullSourceSpan (Qualified (ByModuleName mn) name) mkCtorBinder :: ModuleName -> ProperName 'ConstructorName -> [Binder] -> Binder -mkCtorBinder mn name = ConstructorBinder nullSourceSpan (mkQualified_ (ByModuleName mn) name) +mkCtorBinder mn name = ConstructorBinder nullSourceSpan (Qualified (ByModuleName mn) name) unguarded :: Expr -> [GuardedExpr] unguarded e = [MkUnguarded e] @@ -47,7 +47,7 @@ data UnwrappedTypeConstructor = UnwrappedTypeConstructor } utcQTyCon :: UnwrappedTypeConstructor -> Qualified (ProperName 'TypeName) -utcQTyCon UnwrappedTypeConstructor{..} = mkQualified_ (ByModuleName utcModuleName) utcTyCon +utcQTyCon UnwrappedTypeConstructor{..} = Qualified (ByModuleName utcModuleName) utcTyCon unwrapTypeConstructor :: SourceType -> Maybe UnwrappedTypeConstructor unwrapTypeConstructor = go [] [] diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 3849434151..cb62ba7bef 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -40,7 +40,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (ErrorMessageHint(..), SimpleErrorMessage(..), MultipleErrors(..), rethrow, errorMessage, errorMessage', rethrowWithPosition, addHint) -import Language.PureScript.Names (Ident(..), ModuleName, pattern Qualified, Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified, runProperName) +import Language.PureScript.Names (Ident(..), ModuleName, pattern Qualified, Qualified, QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified, runProperName) import Language.PureScript.Options (CodegenTarget(..), Options(..)) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Traversals (sndM) @@ -393,7 +393,7 @@ moduleBindToJs mn = bindToJs -- Generate code in the simplified JavaScript intermediate representation for a reference to a -- variable that may have a qualified name. - qualifiedToJS :: (Show a, Hashable a) => (a -> Ident) -> Qualified a -> AST + qualifiedToJS :: (Hashable a) => (a -> Ident) -> Qualified a -> AST qualifiedToJS f (Qualified (ByModuleName C.M_Prim) a) = AST.Var Nothing . runIdent $ f a qualifiedToJS f (Qualified (ByModuleName mn') a) | mn /= mn' = AST.ModuleAccessor Nothing mn' . mkString . T.concatMap identCharToText . runIdent $ f a qualifiedToJS f (Qualified _ a) = AST.Var Nothing $ identToJs (f a) diff --git a/src/Language/PureScript/Constants/Libs.hs b/src/Language/PureScript/Constants/Libs.hs index b59cd69de6..f88585c210 100644 --- a/src/Language/PureScript/Constants/Libs.hs +++ b/src/Language/PureScript/Constants/Libs.hs @@ -9,7 +9,7 @@ import Protolude qualified as P import Data.String (IsString) import Language.PureScript.Constants.TH qualified as TH import Language.PureScript.PSString (PSString) -import Language.PureScript.Names (Ident (..), Qualified (..), QualifiedBy (..), pattern Qualified, Qualified(..)) +import Language.PureScript.Names (Ident (..), Qualified, QualifiedBy (..), pattern Qualified) -- Core lib values diff --git a/src/Language/PureScript/Constants/TH.hs b/src/Language/PureScript/Constants/TH.hs index ed1f3e1e2c..b68b1cf812 100644 --- a/src/Language/PureScript/Constants/TH.hs +++ b/src/Language/PureScript/Constants/TH.hs @@ -75,7 +75,7 @@ import Control.Monad.Trans.Writer (Writer, execWriter) import Control.Monad.Writer.Class (tell) import Data.String (String) import Language.Haskell.TH (Dec, Name, Pat, Q, Type, conP, implBidir, litP, mkName, patSynD, patSynSigD, prefixPatSyn, stringL) -import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), Qualified (..)) +import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified, QualifiedBy(..)) -- | Generate pattern synonyms corresponding to the provided PureScript -- declarations. diff --git a/src/Language/PureScript/CoreFn/CSE.hs b/src/Language/PureScript/CoreFn/CSE.hs index 6caabb320b..25ac5ac2ad 100644 --- a/src/Language/PureScript/CoreFn/CSE.hs +++ b/src/Language/PureScript/CoreFn/CSE.hs @@ -26,7 +26,7 @@ import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..)) import Language.PureScript.CoreFn.Meta (Meta(IsSyntheticApp)) import Language.PureScript.CoreFn.Traversals (everywhereOnValues, traverseCoreFn) import Language.PureScript.Environment (dictTypeName) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, pattern Qualified, Qualified(..), QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString, mkQualified_, mapQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, pattern Qualified, QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString, Qualified, mapQualified) import Language.PureScript.PSString (decodeString) -- | @@ -292,7 +292,7 @@ floatExpr topLevelQB = \case let w' = w & (if isNew then newBindings %~ addToScope deepestScope [(ident, (_plurality, e))] else identity) & plurality .~ PluralityMap (M.singleton ident False) - pure (Var nullAnn (mkQualified_ qb ident), w') + pure (Var nullAnn (Qualified qb ident), w') (e, w) -> pure (e, w) -- | diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 874865f4a8..0c999edfbb 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -23,7 +23,7 @@ import Language.PureScript.CoreFn.Module (Module(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), NameKind(..), isDictTypeName, lookupConstructor, lookupValue) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), getQual, runProperName, mkQualified_, mapQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, QualifiedBy(..), getQual, runProperName, Qualified, mapQualified) import Language.PureScript.PSString (PSString) import Language.PureScript.Types (pattern REmptyKinded, SourceType, Type(..)) import Language.PureScript.AST qualified as A @@ -67,7 +67,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = declToCoreFn :: A.Declaration -> [Bind Ann] declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [ctor]) = [NonRec (ss, [], declMeta) (properToIdent $ A.dataCtorName ctor) $ - Abs (ss, com, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ mkQualified_ ByNullSourcePos (Ident "x"))] + Abs (ss, com, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified ByNullSourcePos (Ident "x"))] where declMeta = isDictTypeName (A.dataCtorName ctor) `orEmpty` IsTypeClassConstructor declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = @@ -76,7 +76,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = flip fmap ctors $ \ctorDecl -> let ctor = A.dataCtorName ctorDecl - (_, _, _, fields) = lookupConstructor env (mkQualified_ (ByModuleName mn) ctor) + (_, _, _, fields) = lookupConstructor env (Qualified (ByModuleName mn) ctor) in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing) tyName ctor fields declToCoreFn (A.DataBindingGroupDeclaration ds) = concatMap declToCoreFn ds @@ -172,7 +172,7 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = VarBinder (ss, com, Nothing) name binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor - in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (mkQualified_ mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) + in ConstructorBinder (ss, com, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) binderToCoreFn _ com (A.NamedBinder ss name b) = NamedBinder (ss, com, Nothing) name (binderToCoreFn ss [] b) binderToCoreFn _ com (A.PositionedBinder ss com1 b) = @@ -242,7 +242,7 @@ findQualModules decls = fqBinders (A.ConstructorBinder _ q _) = getQual' q fqBinders _ = [] - getQual' :: (Show a, Hashable a) => Qualified a -> [ModuleName] + getQual' :: (Hashable a) => Qualified a -> [ModuleName] getQual' = maybe [] return . getQual -- | Desugars import declarations from AST to CoreFn representation. diff --git a/src/Language/PureScript/CoreFn/FromJSON.hs b/src/Language/PureScript/CoreFn/FromJSON.hs index 529024b400..5d78c8e1e3 100644 --- a/src/Language/PureScript/CoreFn/FromJSON.hs +++ b/src/Language/PureScript/CoreFn/FromJSON.hs @@ -23,7 +23,7 @@ import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn (Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Guard, Meta(..), Module(..)) -import Language.PureScript.Names (Ident(..), ModuleName(..), properNameFromString, Qualified(..), QualifiedBy(..), unusedIdent, moduleNameFromString, ProperName, mkQualified_) +import Language.PureScript.Names (Ident(..), ModuleName(..), properNameFromString, pattern Qualified, QualifiedBy(..), unusedIdent, moduleNameFromString, ProperName, Qualified) import Language.PureScript.PSString (PSString) import Text.ParserCombinators.ReadP (readP_to_S) @@ -111,7 +111,7 @@ identFromJSON = withText "Ident" $ \case properNameFromJSON :: Value -> Parser (ProperName a) properNameFromJSON = fmap properNameFromString . parseJSON -qualifiedFromJSON :: Show a => Hashable a => (Text -> a) -> Value -> Parser (Qualified a) +qualifiedFromJSON :: Hashable a => (Text -> a) -> Value -> Parser (Qualified a) qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj where qualifiedFromObj o = @@ -119,11 +119,11 @@ qualifiedFromJSON f = withObject "Qualified" qualifiedFromObj qualifiedByModuleFromObj o = do mn <- o .: "moduleName" >>= moduleNameFromJSON i <- o .: "identifier" >>= withText "Ident" (return . f) - pure $ mkQualified_ (ByModuleName mn) i + pure $ Qualified (ByModuleName mn) i qualifiedBySourcePosFromObj o = do ss <- o .: "sourcePos" i <- o .: "identifier" >>= withText "Ident" (return . f) - pure $ mkQualified_ (BySourcePos ss) i + pure $ Qualified (BySourcePos ss) i moduleNameFromJSON :: Value -> Parser ModuleName moduleNameFromJSON v = moduleNameFromString . T.intercalate "." <$> listParser parseJSON v diff --git a/src/Language/PureScript/CoreFn/Laziness.hs b/src/Language/PureScript/CoreFn/Laziness.hs index b87a3274f6..76d93d3f89 100644 --- a/src/Language/PureScript/CoreFn/Laziness.hs +++ b/src/Language/PureScript/CoreFn/Laziness.hs @@ -20,7 +20,7 @@ import Language.PureScript.AST.SourcePos (SourcePos(..), SourceSpan(..), nullSou import Language.PureScript.Constants.Libs qualified as C import Language.PureScript.CoreFn (Ann, Bind, Expr(..), Literal(..), Meta(..), ssAnn, traverseCoreFn) import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, pattern Qualified, Qualified(..), QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), InternalIdentData(..), ModuleName, pattern Qualified, QualifiedBy(..), runIdent, runModuleName, toMaybeModuleName, Qualified) import Language.PureScript.PSString (mkString) -- This module is responsible for ensuring that the bindings in recursive @@ -531,8 +531,8 @@ applyLazinessTransform mn rawItems = let where nullAnn = ssAnn nullSourceSpan - runtimeLazy = Var nullAnn . mkQualified_ ByNullSourcePos $ InternalIdent RuntimeLazyFactory - runFn3 = Var nullAnn . mkQualified_ (ByModuleName C.M_Data_Function_Uncurried) . Ident $ C.S_runFn <> "3" + runtimeLazy = Var nullAnn . Qualified ByNullSourcePos $ InternalIdent RuntimeLazyFactory + runFn3 = Var nullAnn . Qualified (ByModuleName C.M_Data_Function_Uncurried) . Ident $ C.S_runFn <> "3" strLit = Literal nullAnn . StringLiteral . mkString lazifyIdent = \case @@ -545,7 +545,7 @@ applyLazinessTransform mn rawItems = let -- argument: the line number on which this reference is made. The runtime -- code uses this number to generate a message that identifies where the -- evaluation looped. - = App nullAnn (Var nullAnn . mkQualified_ ByNullSourcePos $ lazifyIdent ident) + = App nullAnn (Var nullAnn . Qualified ByNullSourcePos $ lazifyIdent ident) . Literal nullAnn . NumericLiteral . Left . toInteger . sourcePosLine $ spanStart ss diff --git a/src/Language/PureScript/CoreFn/ToJSON.hs b/src/Language/PureScript/CoreFn/ToJSON.hs index 07e2d33e4b..81e357aa36 100644 --- a/src/Language/PureScript/CoreFn/ToJSON.hs +++ b/src/Language/PureScript/CoreFn/ToJSON.hs @@ -23,7 +23,7 @@ import Data.Text qualified as T import Language.PureScript.AST.Literals (Literal(..)) import Language.PureScript.AST.SourcePos (SourceSpan(..)) import Language.PureScript.CoreFn (Ann, Bind(..), Binder(..), CaseAlternative(..), ConstructorType(..), Expr(..), Meta(..), Module(..)) -import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), pattern Qualified, Qualified(..), QualifiedBy(..), runIdent, runModuleName, runProperName) +import Language.PureScript.Names (Ident, ModuleName(..), ProperName(..), pattern Qualified, Qualified, QualifiedBy(..), runIdent, runModuleName, runProperName) import Language.PureScript.PSString (PSString) import Data.Hashable (Hashable) @@ -102,7 +102,7 @@ identToJSON = toJSON . runIdent properNameToJSON :: ProperName a -> Value properNameToJSON = toJSON . runProperName -qualifiedToJSON :: Show a => Hashable a => (a -> Text) -> Qualified a -> Value +qualifiedToJSON :: Hashable a => (a -> Text) -> Qualified a -> Value qualifiedToJSON f (Qualified qb a) = case qb of ByModuleName mn -> object diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 58d00a5709..70913cefc4 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -11,9 +11,9 @@ import Control.Category ((>>>)) import Control.Monad.Writer.Strict (runWriterT) import Control.Monad.Supply (evalSupplyT) import Data.List.NonEmpty qualified as NE -import Data.Map qualified as Map import Data.String (String) import Data.Text qualified as T +import Data.HashMap.Strict qualified as HM import Language.PureScript.Docs.Convert.Single (convertSingleModule) import Language.PureScript.Docs.Types (Declaration(..), DeclarationInfo(..), KindInfo(..), Module(..), Type') @@ -29,7 +29,6 @@ import Language.PureScript.Sugar qualified as P import Language.PureScript.Types qualified as P import Language.PureScript.Constants.Prim qualified as Prim import Language.PureScript.Sugar (RebracketCaller(CalledByDocs)) -import Data.HashMap.Strict qualified as HM -- | -- Convert a single module to a Docs.Module, making use of a pre-existing diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs index 37fd86ab79..72eabd27bb 100644 --- a/src/Language/PureScript/Docs/Prim.hs +++ b/src/Language/PureScript/Docs/Prim.hs @@ -8,16 +8,15 @@ module Language.PureScript.Docs.Prim import Prelude hiding (fail) import Data.Functor (($>)) +import Data.HashMap.Strict qualified as HM import Data.Text (Text) import Data.Text qualified as T -import Data.Map qualified as Map import Language.PureScript.Docs.Types (Declaration(..), DeclarationInfo(..), Module(..), Type', convertFundepsToStrings) import Language.PureScript.Constants.Prim qualified as P import Language.PureScript.Crash qualified as P import Language.PureScript.Environment qualified as P import Language.PureScript.Names qualified as P -import Data.HashMap.Strict qualified as HM primModules :: [Module] primModules = diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 950d75f993..95e9689b00 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -45,7 +45,7 @@ import Data.Text qualified as T import Data.ByteString.Lazy qualified as BS import Data.Text.Encoding qualified as TE -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), moduleNameFromString, runIdent, runModuleName, runProperName, properNameFromString, mkQualified_) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, OpName(..), OpNameType(..), ProperName(..), ProperNameType(..), pattern Qualified, QualifiedBy(..), moduleNameFromString, runIdent, runModuleName, runProperName, properNameFromString, Qualified) import Language.PureScript.AST (Associativity(..)) import Data.Hashable (Hashable) @@ -117,7 +117,7 @@ maybeToContainingModule :: Maybe ModuleName -> ContainingModule maybeToContainingModule Nothing = ThisModule maybeToContainingModule (Just mn) = OtherModule mn -fromQualified :: Show a => Hashable a => Qualified a -> (ContainingModule, a) +fromQualified :: Hashable a => Qualified a -> (ContainingModule, a) fromQualified (Qualified (ByModuleName mn) x) = (OtherModule mn, x) fromQualified (Qualified _ x) = (ThisModule, x) @@ -297,9 +297,9 @@ aliasName for name' = in case ns of ValueLevel -> - ident (mkQualified_ ByNullSourcePos (Ident name)) + ident (Qualified ByNullSourcePos (Ident name)) TypeLevel -> - typeCtor (mkQualified_ ByNullSourcePos (properNameFromString name)) + typeCtor (Qualified ByNullSourcePos (properNameFromString name)) -- | Converts a FixityAlias into a different representation which is more -- useful to other functions in this module. diff --git a/src/Language/PureScript/Interactive/Printer.hs b/src/Language/PureScript/Interactive/Printer.hs index 8264ef2d10..af8405e21c 100644 --- a/src/Language/PureScript/Interactive/Printer.hs +++ b/src/Language/PureScript/Interactive/Printer.hs @@ -3,7 +3,7 @@ module Language.PureScript.Interactive.Printer where import Prelude import Data.List (intersperse) -import Data.Map qualified as M +import Data.HashMap.Strict qualified as HM import Data.Maybe (mapMaybe) import Data.Text qualified as T import Data.Text (Text) @@ -11,7 +11,6 @@ import Language.PureScript qualified as P import Text.PrettyPrint.Boxes qualified as Box import Data.Hashable (Hashable) import Language.PureScript.Names (mapQualified) -import Data.HashMap.Strict qualified as HM -- TODO (Christoph): Text version of boxes textT :: Text -> Box.Box @@ -30,7 +29,7 @@ printModuleSignatures moduleName P.Environment{..} = moduleTypes = byModuleName types - byModuleName :: Show a => Hashable a => HM.HashMap (P.Qualified a) b -> [P.Qualified a] + byModuleName :: Hashable a => HM.HashMap (P.Qualified a) b -> [P.Qualified a] byModuleName = filter ((== Just moduleName) . P.getQual) . HM.keys in diff --git a/src/Language/PureScript/Interner.hs b/src/Language/PureScript/Interner.hs index 068f0e5995..7f3b28fc71 100644 --- a/src/Language/PureScript/Interner.hs +++ b/src/Language/PureScript/Interner.hs @@ -12,8 +12,8 @@ import Control.Exception import Control.Monad (when) import Data.Hashable (Hashable, hash, hashWithSalt) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import GHC.Base (compareInt#, Int#, IO (..), anyToAddr#, addr2Int#) -import GHC.Exts (Any, Addr#, unsafeCoerce#) +import GHC.Base (compareInt#, IO (..), anyToAddr#, addr2Int#) +import GHC.Exts (Any, unsafeCoerce#) import System.IO.Unsafe (unsafeDupablePerformIO) import Text.ParserCombinators.ReadPrec (step) import Text.Read (Read(..), lexP, parens, prec) @@ -126,8 +126,8 @@ compareAndSubstitute cmp eq ref1 ref2 = unsafeDupablePerformIO $ do -- that they are not (i.e. because (==) on their type unconditionally -- returns True), we need to ensure they are not thunks, according to the -- documentation of anyToAddr# - evaluate a1 - evaluate a2 + _ <- evaluate a1 + _ <- evaluate a2 -- NOTE: There is a race condition here: the addresses could change in -- between when they are read. However, since either (or neither) swap is -- fine, we are OK with this only working "most" of the time (which we diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs index 62ec7c1a54..c48c94cfd3 100644 --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -17,7 +17,6 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.List (foldl', sortOn) import Data.Maybe (fromMaybe) -import Data.Map qualified as M import Data.Text qualified as T import Language.PureScript.AST.Binders (Binder(..)) @@ -49,7 +48,7 @@ qualifyName -> ModuleName -> Qualified (ProperName b) -> Qualified (ProperName a) -qualifyName n defmn qn = mkQualified_ (ByModuleName mn) n +qualifyName n defmn qn = Qualified (ByModuleName mn) n where (mn, _) = qualify defmn qn diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 08bd655a03..1eb8959acc 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -185,7 +185,6 @@ lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do extractByQual :: Hashable a - => Show a => ModuleName -> M.Map (Qualified a) [ImportRecord a] -> (a -> Name) diff --git a/src/Language/PureScript/Make/ExternsDiff.hs b/src/Language/PureScript/Make/ExternsDiff.hs index 1d982e4721..becb058fa8 100644 --- a/src/Language/PureScript/Make/ExternsDiff.hs +++ b/src/Language/PureScript/Make/ExternsDiff.hs @@ -388,7 +388,7 @@ typeDeps = P.everythingOnTypes (<>) $ internalError "typeDeps: type is not qualified" _ -> mempty -qualified :: (Show b, Hashable b) => P.Qualified b -> (ModuleName, b) +qualified :: (Hashable b) => P.Qualified b -> (ModuleName, b) qualified (P.Qualified (P.ByModuleName mn) v) = (mn, v) qualified _ = internalError "ExternsDiff: type is not qualified" diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 20f5296846..5889bc2297 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -298,29 +298,29 @@ traverseQualified f (QualifiedCons (unHashCons -> q)) = QualifiedCons . hashCons {-# COMPLETE Qualified #-} -pattern Qualified :: (Show a, Hashable a) => QualifiedBy -> a -> Qualified a +pattern Qualified :: (Hashable a) => QualifiedBy -> a -> Qualified a pattern Qualified qb a <- QualifiedCons (unHashCons -> Qualified' qb a) where Qualified qb a = mkQualified_ qb a -showQualified :: (Show a, Hashable a) => (a -> Text) -> Qualified a -> Text +showQualified :: (Hashable a) => (a -> Text) -> Qualified a -> Text showQualified f (Qualified (BySourcePos _) a) = f a showQualified f (Qualified (ByModuleName name) a) = runModuleName name <> "." <> f a -getQual :: (Show a, Hashable a) => Qualified a -> Maybe ModuleName +getQual :: (Hashable a) => Qualified a -> Maybe ModuleName getQual (Qualified qb _) = toMaybeModuleName qb -- | -- Provide a default module name, if a name is unqualified -- -qualify :: (Show a, Hashable a) => ModuleName -> Qualified a -> (ModuleName, a) +qualify :: (Hashable a) => ModuleName -> Qualified a -> (ModuleName, a) qualify m (Qualified (BySourcePos _) a) = (m, a) qualify _ (Qualified (ByModuleName m) a) = (m, a) -- | -- Makes a qualified value from a name and module name. -- -mkQualified :: ( Hashable a) =>a -> ModuleName -> Qualified a +mkQualified :: (Hashable a) =>a -> ModuleName -> Qualified a mkQualified name mn = let qb = ByModuleName mn @@ -331,43 +331,43 @@ mkQualified_ qb name = QualifiedCons (hashCons (Qualified' qb name)) -- | Remove the module name from a qualified name -disqualify :: (Show a, Hashable a) => Qualified a -> a +disqualify :: (Hashable a) => Qualified a -> a disqualify (Qualified _ a) = a -- | -- Remove the qualification from a value when it is qualified with a particular -- module name. -- -disqualifyFor :: (Show a, Hashable a) => Maybe ModuleName -> Qualified a -> Maybe a +disqualifyFor :: (Hashable a) => Maybe ModuleName -> Qualified a -> Maybe a disqualifyFor mn (Qualified qb a) | mn == toMaybeModuleName qb = Just a disqualifyFor _ _ = Nothing -- | -- Checks whether a qualified value is actually qualified with a module reference -- -isQualified :: (Show a, Hashable a) => Qualified a -> Bool +isQualified :: (Hashable a) => Qualified a -> Bool isQualified (Qualified (BySourcePos _) _) = False isQualified _ = True -- | -- Checks whether a qualified value is not actually qualified with a module reference -- -isUnqualified :: (Show a, Hashable a) => Qualified a -> Bool +isUnqualified :: (Hashable a) => Qualified a -> Bool isUnqualified = not . isQualified -- | -- Checks whether a qualified value is qualified with a particular module -- -isQualifiedWith :: (Show a, Hashable a) => ModuleName -> Qualified a -> Bool +isQualifiedWith :: (Hashable a) => ModuleName -> Qualified a -> Bool isQualifiedWith mn (Qualified (ByModuleName mn') _) = mn == mn' isQualifiedWith _ _ = False -instance (Show a, Hashable a, ToJSON a) => ToJSON (Qualified a) where +instance (Hashable a, ToJSON a) => ToJSON (Qualified a) where toJSON (Qualified qb a) = case qb of ByModuleName mn -> toJSON2 (mn, a) BySourcePos ss -> toJSON2 (ss, a) -instance (Show a, FromJSON a, Hashable a) => FromJSON (Qualified a) where +instance (FromJSON a, Hashable a) => FromJSON (Qualified a) where parseJSON v = byModule <|> bySourcePos <|> byMaybeModuleName' where byModule = do diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index aab1e029de..efce244c0e 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -28,7 +28,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage'', nonEmpty, parU, warnAndRethrow, warnAndRethrowWithPosition) import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..), ExternsImport(..)) import Language.PureScript.Linter.Imports (Name(..), UsedImports) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), mkQualified_, mapQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident, OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, QualifiedBy(..), Qualified, mapQualified) import Language.PureScript.Sugar.Names.Env (Env, Exports(..), ImportProvenance(..), ImportRecord(..), Imports(..), checkImportConflicts, nullImports, primEnv) import Language.PureScript.Sugar.Names.Exports (findExportable, resolveExports) import Language.PureScript.Sugar.Names.Imports (resolveImports, resolveModuleImport) @@ -236,12 +236,12 @@ renameInModule imports (Module modSS coms mn decls exps) = updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Left alias)) op) = fmap (bound,) $ ValueFixityDeclaration sa fixity . mapQualified Left - <$> updateValueName (mkQualified_ mn' alias) ss + <$> updateValueName (Qualified mn' alias) ss <*> pure op updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Right alias)) op) = fmap (bound,) $ ValueFixityDeclaration sa fixity . mapQualified Right - <$> updateDataConstructorName (mkQualified_ mn' alias) ss + <$> updateDataConstructorName (Qualified mn' alias) ss <*> pure op updateDecl b d = return (b, d) @@ -269,7 +269,7 @@ renameInModule imports (Module modSS coms mn decls exps) = ((ss, bound), ) <$> case (M.lookup ident bound, qualifiedBy) of -- bound idents that have yet to be locally qualified. (Just sourcePos, ByNullSourcePos) -> - pure $ Var ss (mkQualified_ (BySourcePos sourcePos) ident) + pure $ Var ss (Qualified (BySourcePos sourcePos) ident) -- unbound idents are likely import unqualified imports, so we -- handle them through updateValueName if they don't exist as a -- local binding. @@ -407,7 +407,7 @@ renameInModule imports (Module modSS coms mn decls exps) = -- qualified references are replaced with their canonical qualified names -- (e.g. M.Map -> Data.Map.Map). update - :: (Ord a, Hashable a, Show a) + :: (Ord a, Hashable a) => M.Map (Qualified a) [ImportRecord a] -> (a -> Name) -> Qualified a @@ -425,7 +425,7 @@ renameInModule imports (Module modSS coms mn decls exps) = (mnNew, mnOrig) <- checkImportConflicts pos mn toName options modify $ \usedImports -> M.insertWith (++) mnNew [mapQualified toName qname] usedImports - return $ mkQualified_ (ByModuleName mnOrig) name + return $ Qualified (ByModuleName mnOrig) name -- If the name wasn't found in our imports but was qualified then we need -- to check whether it's a failed import from a "pseudo" module (created @@ -434,7 +434,7 @@ renameInModule imports (Module modSS coms mn decls exps) = (Nothing, ByModuleName mn'') -> if mn'' `S.member` importedQualModules imports || mn'' `S.member` importedModules imports then throwUnknown - else throwError . errorMessage . UnknownName . mkQualified_ ByNullSourcePos $ ModName mn'' + else throwError . errorMessage . UnknownName . Qualified ByNullSourcePos $ ModName mn'' -- If neither of the above cases are true then it's an undefined or -- unimported symbol. diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index a17b71a871..e03eab139e 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -37,7 +37,7 @@ import Language.PureScript.AST (ExportSource(..), SourceSpan, internalModuleSour import Language.PureScript.Crash (internalError) import Language.PureScript.Environment import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage') -import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, disqualify, getQual, mkQualified_) +import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, QualifiedBy(..), coerceProperName, disqualify, getQual, Qualified) import Data.Hashable (Hashable) import Data.HashMap.Strict qualified as HM @@ -465,7 +465,7 @@ throwExportConflict' -> m a throwExportConflict' ss new existing newName existingName = throwError . errorMessage' ss $ - ExportConflict (mkQualified_ (ByModuleName new) newName) (mkQualified_ (ByModuleName existing) existingName) + ExportConflict (Qualified (ByModuleName new) newName) (Qualified (ByModuleName existing) existingName) -- | -- When reading a value from the imports, check that there are no conflicts in @@ -473,7 +473,7 @@ throwExportConflict' ss new existing newName existingName = -- checkImportConflicts :: forall m a - . (Hashable a, Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m) + . (Hashable a, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => SourceSpan -> ModuleName -> (a -> Name) diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 48f613a167..4f8bcbba75 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -18,7 +18,7 @@ import Data.Map qualified as M import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', rethrow, rethrowWithPosition, warnAndRethrow) -import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), disqualifyFor, isQualifiedWith, isUnqualified) +import Language.PureScript.Names (Ident, ModuleName, Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified, QualifiedBy(..), disqualifyFor, isQualifiedWith, isUnqualified) import Language.PureScript.Sugar.Names.Env (Env, ExportMode(..), Exports(..), ImportRecord(..), Imports(..), checkImportConflicts, envModuleExports, exportType, exportTypeClass, exportTypeOp, exportValue, exportValueOp, nullExports) import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) import Data.Hashable (Hashable) @@ -123,7 +123,6 @@ resolveExports env ss mn imps exps refs = -- boolean is true the values are filtered by the qualification extract :: Hashable a - => Show a => SourceSpan -> Bool -> ModuleName @@ -213,7 +212,7 @@ resolveExports env ss mn imps exps refs = $ resolve exportedValueOps op resolve - :: (Ord a, Hashable a, Show a) + :: (Ord a, Hashable a) => (Exports -> M.Map a ExportSource) -> Qualified a -> Maybe (a, ExportSource) diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index b048769f93..d689f66e2b 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -211,7 +211,7 @@ resolveImport importModule exps imps impQual = resolveByType -- Add something to an import resolution list updateImports - :: (Ord a, Hashable a, Show a) + :: (Ord a, Hashable a) => M.Map (Qualified a) [ImportRecord a] -> M.Map a b -> (b -> ExportSource) diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 058097d6ff..b0ae66082c 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -19,7 +19,7 @@ import Language.PureScript.AST import Language.PureScript.Crash (internalError) import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage, errorMessage', parU, rethrow, rethrowWithPosition) import Language.PureScript.Externs (ExternsFile(..), ExternsFixity(..), ExternsTypeFixity(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), freshIdent', mkQualified_, mapQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), Name(..), OpName, OpNameType(..), ProperName, ProperNameType(..), pattern Qualified, QualifiedBy(..), freshIdent', Qualified, mapQualified) import Language.PureScript.Sugar.Operators.Binders (matchBinderOperators) import Language.PureScript.Sugar.Operators.Expr (matchExprOperators) import Language.PureScript.Sugar.Operators.Types (matchTypeOperators) @@ -51,7 +51,7 @@ desugarSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts where (f', _, _) = everywhereOnValues id go id - go (UnaryMinus ss' val) = App (Var ss' (mkQualified_ ByNullSourcePos (Ident C.S_negate))) val + go (UnaryMinus ss' val) = App (Var ss' (Qualified ByNullSourcePos (Ident C.S_negate))) val go other = other -- | @@ -113,7 +113,7 @@ rebracketFiltered !caller pred_ externs m = do where ensureNoDuplicates' - :: (Ord op, Hashable op, Show op) + :: (Ord op, Hashable op) => (op -> SimpleErrorMessage) -> [FixityRecord op alias] -> m () @@ -152,9 +152,9 @@ rebracketFiltered !caller pred_ externs m = do goExpr _ (Op pos op) = (pos,) <$> case op `M.lookup` valueAliased of Just (Qualified mn' (Left alias)) -> - return $ Var pos (mkQualified_ mn' alias) + return $ Var pos (Qualified mn' alias) Just (Qualified mn' (Right alias)) -> - return $ Constructor pos (mkQualified_ mn' alias) + return $ Constructor pos (Qualified mn' alias) Nothing -> throwError . errorMessage' pos . UnknownName $ mapQualified ValOpName op goExpr pos other = return (pos, other) @@ -164,9 +164,9 @@ rebracketFiltered !caller pred_ externs m = do goBinder _ (BinaryNoParensBinder (OpBinder pos op) lhs rhs) = case op `M.lookup` valueAliased of Just (Qualified mn' (Left alias)) -> - throwError . errorMessage' pos $ InvalidOperatorInBinder op (mkQualified_ mn' alias) + throwError . errorMessage' pos $ InvalidOperatorInBinder op (Qualified mn' alias) Just (Qualified mn' (Right alias)) -> - return (pos, ConstructorBinder pos (mkQualified_ mn' alias) [lhs, rhs]) + return (pos, ConstructorBinder pos (Qualified mn' alias) [lhs, rhs]) Nothing -> throwError . errorMessage' pos . UnknownName $ mapQualified ValOpName op goBinder _ BinaryNoParensBinder{} = @@ -255,9 +255,9 @@ removeBinaryNoParens u where err = throwError . errorMessage $ IncorrectAnonymousArgument removeBinaryNoParens (Parens (stripPositionInfo -> BinaryNoParens op l r)) | isAnonymousArgument r = do arg <- freshIdent' - return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (mkQualified_ ByNullSourcePos arg)) + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op l) (Var nullSourceSpan (Qualified ByNullSourcePos arg)) | isAnonymousArgument l = do arg <- freshIdent' - return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (mkQualified_ ByNullSourcePos arg))) r + return $ Abs (VarBinder nullSourceSpan arg) $ App (App op (Var nullSourceSpan (Qualified ByNullSourcePos arg))) r removeBinaryNoParens (BinaryNoParens op l r) = return $ App (App op l) r removeBinaryNoParens e = return e @@ -304,7 +304,7 @@ externsFixities ExternsFile{..} = -> Either ValueFixityRecord TypeFixityRecord fromFixity (ExternsFixity assoc prec op name) = Left - ( mkQualified_ (ByModuleName efModuleName) op + ( Qualified (ByModuleName efModuleName) op , internalModuleSourceSpan "" , Fixity assoc prec , name @@ -315,7 +315,7 @@ externsFixities ExternsFile{..} = -> Either ValueFixityRecord TypeFixityRecord fromTypeFixity (ExternsTypeFixity assoc prec op name) = Right - ( mkQualified_ (ByModuleName efModuleName) op + ( Qualified (ByModuleName efModuleName) op , internalModuleSourceSpan "" , Fixity assoc prec , name @@ -326,13 +326,13 @@ collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord] collect (ValueFixityDeclaration (ss, _) fixity name op) = - [Left (mkQualified_ (ByModuleName moduleName) op, ss, fixity, name)] + [Left (Qualified (ByModuleName moduleName) op, ss, fixity, name)] collect (TypeFixityDeclaration (ss, _) fixity name op) = - [Right (mkQualified_ (ByModuleName moduleName) op, ss, fixity, name)] + [Right (Qualified (ByModuleName moduleName) op, ss, fixity, name)] collect _ = [] ensureNoDuplicates - :: (Hashable a, Ord a, Show a, MonadError MultipleErrors m) + :: (Hashable a, Ord a, MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> [(Qualified a, SourceSpan)] -> m () diff --git a/src/Language/PureScript/Sugar/Operators/Binders.hs b/src/Language/PureScript/Sugar/Operators/Binders.hs index 62d1d78b68..82834f154d 100644 --- a/src/Language/PureScript/Sugar/Operators/Binders.hs +++ b/src/Language/PureScript/Sugar/Operators/Binders.hs @@ -6,7 +6,7 @@ import Control.Monad.Except (MonadError) import Language.PureScript.AST (Associativity, Binder(..), SourceSpan) import Language.PureScript.Errors (MultipleErrors) -import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified(..)) +import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified) import Language.PureScript.Sugar.Operators.Common (matchOperators) matchBinderOperators diff --git a/src/Language/PureScript/Sugar/Operators/Expr.hs b/src/Language/PureScript/Sugar/Operators/Expr.hs index f21056162b..9c6792a8fb 100644 --- a/src/Language/PureScript/Sugar/Operators/Expr.hs +++ b/src/Language/PureScript/Sugar/Operators/Expr.hs @@ -9,7 +9,7 @@ import Text.Parsec qualified as P import Text.Parsec.Expr qualified as P import Language.PureScript.AST (Associativity, Expr(..), SourceSpan) -import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified(..)) +import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified) import Language.PureScript.Sugar.Operators.Common (Chain, matchOperators, token) import Language.PureScript.Errors (MultipleErrors) diff --git a/src/Language/PureScript/Sugar/Operators/Types.hs b/src/Language/PureScript/Sugar/Operators/Types.hs index 34dc882b90..683aa72416 100644 --- a/src/Language/PureScript/Sugar/Operators/Types.hs +++ b/src/Language/PureScript/Sugar/Operators/Types.hs @@ -5,7 +5,7 @@ import Prelude import Control.Monad.Except (MonadError) import Language.PureScript.AST (Associativity, SourceSpan) import Language.PureScript.Errors (MultipleErrors) -import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified(..)) +import Language.PureScript.Names (OpName(..), OpNameType(..), pattern Qualified, Qualified) import Language.PureScript.Sugar.Operators.Common (matchOperators) import Language.PureScript.Types (SourceType, Type(..), srcTypeApp) diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index c0da3bb8e8..02041a4869 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -18,7 +18,6 @@ import Control.Monad.Supply.Class (MonadSupply) import Data.Graph (SCC(..), stronglyConnComp) import Data.List (find, partition) import Data.List.NonEmpty (nonEmpty) -import Data.Map qualified as M import Data.Maybe (catMaybes, mapMaybe, isJust) import Data.List.NonEmpty qualified as NEL import Data.Set qualified as S @@ -30,7 +29,7 @@ import Language.PureScript.Environment (DataDeclType(..), NameKind(..), TypeClas import Language.PureScript.Errors hiding (isExported, nonEmpty) import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..)) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent, mkQualified_, mapQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, Name(..), ProperName, ProperNameType(..), pattern Qualified, QualifiedBy(..), coerceProperName, freshIdent, qualify, runIdent, Qualified, mapQualified) import Language.PureScript.PSString (mkString) import Language.PureScript.Sugar.CaseDeclarations (desugarCases) import Language.PureScript.TypeClassDictionaries (superclassName) @@ -102,7 +101,7 @@ desugarModule (Module ss coms name decls (Just exps)) = do constraintName (Constraint _ cName _ _ _) = cName classDeclName :: Declaration -> Qualified (ProperName 'ClassName) - classDeclName (TypeClassDeclaration _ pn _ _ _ _) = mkQualified_ (ByModuleName name) pn + classDeclName (TypeClassDeclaration _ pn _ _ _ _) = Qualified (ByModuleName name) pn classDeclName _ = internalError "Expected TypeClassDeclaration" desugarModule _ = internalError "Exports should have been elaborated in name desugaring" @@ -297,15 +296,15 @@ typeClassMemberToDictionaryAccessor -> Declaration -> Declaration typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration (TypeDeclarationData sa@(ss, _) ident ty)) = - let className = mkQualified_ (ByModuleName mn) name + let className = Qualified (ByModuleName mn) name dictIdent = Ident "dict" dictObjIdent = Ident "v" ctor = ConstructorBinder ss (coerceProperName . dictTypeName `mapQualified` className) [VarBinder ss dictObjIdent] - acsr = Accessor (mkString $ runIdent ident) (Var ss (mkQualified_ ByNullSourcePos dictObjIdent)) + acsr = Accessor (mkString $ runIdent ident) (Var ss (Qualified ByNullSourcePos dictObjIdent)) visibility = second (const TypeVarVisible) <$> args in ValueDecl sa ident Private [] [MkUnguarded ( - TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ mkQualified_ ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ + TypedValue False (Abs (VarBinder ss dictIdent) (Case [Var ss $ Qualified ByNullSourcePos dictIdent] [CaseAlternative [ctor] [MkUnguarded acsr]])) $ addVisibility visibility (moveQuantifiersToFront NullSourceAnn (quantify (srcConstrainedType (srcConstraint className [] (map (srcTypeVar . fst) args) Nothing) ty))) )] typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" diff --git a/src/Language/PureScript/TypeChecker/Deriving.hs b/src/Language/PureScript/TypeChecker/Deriving.hs index a1982871b5..e8666d0ff8 100644 --- a/src/Language/PureScript/TypeChecker/Deriving.hs +++ b/src/Language/PureScript/TypeChecker/Deriving.hs @@ -12,7 +12,6 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Data.Align (align, unalign) import Data.Foldable (foldl1, foldr1) import Data.List (init, last, zipWith3, (!!)) -import Data.Map qualified as M import Data.These (These(..), mergeTheseWith, these) import Language.PureScript.AST (Binder(..), CaseAlternative(..), ErrorMessageHint(..), Expr(..), InstanceDerivationStrategy(..), Literal(..), SourceSpan, nullSourceSpan) @@ -23,7 +22,7 @@ import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), FunctionalDependency(..), TypeClassData(..), TypeKind(..), kindType, (-:>)) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, errorMessage, internalCompilerError) import Language.PureScript.Label (Label(..)) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString, mkQualified_, mapQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName(..), Name(..), ProperName(..), ProperNameType(..), pattern Qualified, QualifiedBy(..), coerceProperName, freshIdent, qualify, properNameFromString, Qualified, mapQualified) import Language.PureScript.PSString (PSString, mkString) import Language.PureScript.Sugar.TypeClasses (superClassDictionaryNames) import Language.PureScript.TypeChecker.Entailment (InstanceContext, findDicts) @@ -170,7 +169,7 @@ deriveNewtypeInstance className tys (UnwrappedTypeConstructor mn tyConNm dkargs -- newtype-derived; see #3168. The whole verifySuperclasses feature -- is pretty sketchy, and could use a thorough review and probably rewrite. hasNewtypeSuperclassInstance (suModule, suClass) nt@(newtypeModule, _) dicts = - let su = mkQualified_ (ByModuleName suModule) suClass + let su = Qualified (ByModuleName suModule) suClass lookIn mn' = elem nt . (toList . extractNewtypeName mn' . tcdInstanceTypes @@ -340,11 +339,11 @@ lookupTypeDecl lookupTypeDecl mn typeName = do env <- getEnv note (errorMessage $ CannotFindDerivingType typeName) $ do - (kind, DataType _ args dctors) <- mkQualified_ (ByModuleName mn) typeName `HM.lookup` types env + (kind, DataType _ args dctors) <- Qualified (ByModuleName mn) typeName `HM.lookup` types env (kargs, _) <- completeBinderList kind let dtype = do (ctorName, _) <- headMay dctors - (a, _, _, _) <- mkQualified_ (ByModuleName mn) ctorName `HM.lookup` dataConstructors env + (a, _, _, _) <- Qualified (ByModuleName mn) ctorName `HM.lookup` dataConstructors env pure a pure (dtype, fst . snd <$> kargs, map (\(v, k, _) -> (v, k)) args, dctors) @@ -518,8 +517,8 @@ validateParamsInTypeConstructors derivingClass utc isBi CovariantClasses{..} con headOfType = fix $ \go -> \case TypeApp _ ty _ -> go ty KindApp _ ty _ -> go ty - TypeVar _ nm -> mkQualified_ ByNullSourcePos (Left nm) - Skolem _ nm _ _ _ -> mkQualified_ ByNullSourcePos (Left nm) + TypeVar _ nm -> Qualified ByNullSourcePos (Left nm) + Skolem _ nm _ _ _ -> Qualified ByNullSourcePos (Left nm) TypeConstructor _ (Qualified qb nm) -> Qualified qb (Right nm) ty -> internalError $ "headOfType missing a case: " <> show (void ty) diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index 21595a7dab..a2a77dc4c5 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -40,7 +40,7 @@ import Language.PureScript.AST.Declarations (UnknownsHint(..)) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString) import Language.PureScript.Errors (SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow) -import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName, mkQualified_, mapQualified) +import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual, runProperName, Qualified, mapQualified) import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds) import Language.PureScript.TypeChecker.Entailment.IntCompare (mkFacts, mkRelation, solveRelation) import Language.PureScript.TypeChecker.Kinds (elaborateKind, unifyKinds') @@ -312,7 +312,7 @@ entails SolverOptions{..} constraint context hints = Unsolved unsolved -> do -- Generate a fresh name for the unsolved constraint's new dictionary ident <- freshIdent ("dict" <> runProperName (disqualify (constraintClass unsolved))) - let qident = mkQualified_ ByNullSourcePos ident + let qident = Qualified ByNullSourcePos ident -- Store the new dictionary in the InstanceContext so that we can solve this goal in -- future. newDicts <- lift . lift $ newDictionaries [] qident unsolved @@ -377,7 +377,7 @@ entails SolverOptions{..} constraint context hints = tcdToInstanceDescription TypeClassDictionaryInScope{ tcdDescription, tcdValue } = let nii = namedInstanceIdentifier tcdValue in case tcdDescription of - Just ty -> flip mkQualified_ (Left ty) <$> fmap (byMaybeModuleName . getQual) nii + Just ty -> flip Qualified (Left ty) <$> fmap (byMaybeModuleName . getQual) nii Nothing -> mapQualified Right <$> nii canBeGeneralized :: Type a -> Bool @@ -442,7 +442,7 @@ entails SolverOptions{..} constraint context hints = where -- Only keep type class members that need VTAs to resolve their type class instances qualifyAndFilter (ident, _, mbVtaRequiredArgs) = mbVtaRequiredArgs <&> \vtaRequiredArgs -> - (mkQualified_ (ByModuleName tyClassModuleName) ident, map (map indexToArgText . NEL.toList) $ S.toList vtaRequiredArgs) + (Qualified (ByModuleName tyClassModuleName) ident, map (map indexToArgText . NEL.toList) $ S.toList vtaRequiredArgs) tyClassMembersInExpr :: Expr -> [(Qualified Ident, [[Text]])] tyClassMembersInExpr = getVars diff --git a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs index fcf4155858..16dfa538f2 100644 --- a/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs +++ b/src/Language/PureScript/TypeChecker/Entailment/Coercible.hs @@ -34,11 +34,12 @@ import Data.Text (Text) import Data.Map qualified as M import Data.Set qualified as S +import Data.HashMap.Strict qualified as HM import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (DataDeclType(..), Environment(..), TypeKind(..), unapplyKinds) import Language.PureScript.Errors (DeclarationRef(..), ErrorMessageHint(..), ExportSource, ImportDeclarationType(..), MultipleErrors, SimpleErrorMessage(..), SourceAnn, errorMessage, UnknownsHint(..)) -import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), pattern Qualified, Qualified(..), byMaybeModuleName, toMaybeModuleName, mkQualified_) +import Language.PureScript.Names (ModuleName, ProperName, ProperNameType(..), pattern Qualified, byMaybeModuleName, toMaybeModuleName, Qualified) import Language.PureScript.TypeChecker.Kinds (elaborateKind, freshKindWithKind, unifyKinds') import Language.PureScript.TypeChecker.Monad (CheckState(..), TypeCheckM) import Language.PureScript.TypeChecker.Roles (lookupRoles) @@ -47,7 +48,6 @@ import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, import Language.PureScript.Roles (Role(..)) import Language.PureScript.Types (Constraint(..), SourceType, Type(..), completeBinderList, containsUnknowns, everythingOnTypes, isMonoType, replaceAllTypeVars, rowFromList, srcConstraint, srcTypeApp, unapplyTypes) import Language.PureScript.Constants.Prim qualified as Prim -import Data.HashMap.Strict qualified as HM -- | State of the given constraints solver. data GivenSolverState = @@ -681,7 +681,7 @@ lookupNewtypeConstructorInScope env currentModuleName currentModuleImports quali isImported = isJust fromModule inScope = isDefinedInCurrentModule || isImported (tvs, ctorName, wrappedTy) <- lookupNewtypeConstructor env qualifiedNewtypeName ks - pure (inScope, fromModuleName, tvs, mkQualified_ (byMaybeModuleName asModuleName) ctorName, wrappedTy) + pure (inScope, fromModuleName, tvs, Qualified (byMaybeModuleName asModuleName) ctorName, wrappedTy) where isNewtypeCtorImported (_, _, importDeclType, _, exportedTypes) = case M.lookup newtypeName exportedTypes of diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index ac2212b3f8..f47d0ebe7b 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -22,7 +22,7 @@ import Data.List.NonEmpty qualified as NEL import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (Environment(..), NameKind(..), NameVisibility(..), TypeClassData(..), TypeKind(..)) import Language.PureScript.Errors (Context, ErrorMessageHint, ExportSource, Expr, ImportDeclarationType, MultipleErrors, SimpleErrorMessage(..), SourceAnn, SourceSpan(..), addHint, errorMessage, positionedError, rethrow, warnWithPosition) -import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified, pattern Qualified, QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString, mkQualified_, mapQualified) +import Language.PureScript.Names (Ident(..), ModuleName, ProperName(..), ProperNameType(..), pattern Qualified, QualifiedBy(..), coerceProperName, disqualify, runIdent, runModuleName, showQualified, toMaybeModuleName, runProperName, properNameFromString, Qualified, mapQualified) import Language.PureScript.Pretty.Types (prettyPrintType) import Language.PureScript.Pretty.Values (prettyPrintValue) import Language.PureScript.TypeClassDictionaries (NamedDict, TypeClassDictionaryInScope(..)) @@ -38,7 +38,6 @@ import Data.HashMap.Strict qualified as HM import Data.HashSet qualified as HS import Control.Monad.Identity (Identity(runIdentity)) import Control.Monad (forM_, when, join, (<=<), guard) -import Data.IntSet (IntSet) newtype TypeCheckM a = TypeCheckM { unTypeCheckM :: StateT CheckState (SupplyT (ExceptT MultipleErrors (SW.Writer MultipleErrors))) a } deriving newtype (Functor, Applicative, Monad, MonadSupply, MonadState CheckState, MonadWriter MultipleErrors, MonadError MultipleErrors) @@ -179,9 +178,9 @@ withScopedTypeVars withScopedTypeVars mn ks ma = do orig <- get forM_ ks $ \(name, _) -> - when (mkQualified_ (ByModuleName mn) (properNameFromString name) `HM.member` types (checkEnv orig)) $ + when (Qualified (ByModuleName mn) (properNameFromString name) `HM.member` types (checkEnv orig)) $ tell . errorMessage $ ShadowedTypeVar name - bindTypes (HM.fromList (map (\(name, k) -> (mkQualified_ (ByModuleName mn) (properNameFromString name), (k, ScopedTypeVar))) ks)) ma + bindTypes (HM.fromList (map (\(name, k) -> (Qualified (ByModuleName mn) (properNameFromString name), (k, ScopedTypeVar))) ks)) ma withErrorMessageHint :: (MonadState CheckState m, MonadError MultipleErrors m) @@ -257,7 +256,7 @@ bindLocalVariables -> TypeCheckM a -> TypeCheckM a bindLocalVariables bindings = - bindNames (HM.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (mkQualified_ (BySourcePos $ spanStart ss) name, (ty, Private, visibility))) + bindNames (HM.fromList $ flip map bindings $ \(ss, name, ty, visibility) -> (Qualified (BySourcePos $ spanStart ss) name, (ty, Private, visibility))) -- | Temporarily bind a collection of names to local type variables bindLocalTypeVariables @@ -266,7 +265,7 @@ bindLocalTypeVariables -> TypeCheckM a -> TypeCheckM a bindLocalTypeVariables moduleName bindings = - bindTypes (HM.fromList $ flip map bindings $ \(pn, kind) -> (mkQualified_ (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) + bindTypes (HM.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (ByModuleName moduleName) pn, (kind, LocalTypeVariable))) -- | Update the visibility of all names to Defined makeBindingGroupVisible :: TypeCheckM () @@ -321,7 +320,7 @@ lookupTypeVariable -> TypeCheckM SourceType lookupTypeVariable currentModule (Qualified qb name) = do env <- getEnv - case HM.lookup (mkQualified_ qb' name) (types env) of + case HM.lookup (Qualified qb' name) (types env) of Nothing -> throwError . errorMessage $ UndefinedTypeVariable name Just (k, _) -> return k where diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 7279e62f61..97a4d5031a 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -13,7 +13,6 @@ import Prelude import Control.Monad.Error.Class (MonadError(..)) import Data.Maybe (fromMaybe) -import Data.Map qualified as M import Data.HashMap.Strict qualified as HM import Data.Text (Text) import Language.PureScript.Environment (Environment(..), TypeKind) diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 6e0ae400f4..4be101bc03 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -5,7 +5,6 @@ module Language.PureScript.TypeChecker.TypeSearch import Protolude import Control.Monad.Writer (WriterT, runWriterT) -import Data.Map qualified as Map import Data.HashMap.Strict qualified as HM import Language.PureScript.TypeChecker.Entailment qualified as Entailment @@ -23,7 +22,6 @@ import Language.PureScript.TypeChecker.Synonyms as P import Language.PureScript.Types as P import Control.Monad.Supply qualified as P import Language.PureScript.TypeChecker.Monad qualified as P -import Data.HashMap.Strict qualified as HM.HashMap checkInEnvironment :: Environment diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index a1647610ee..d067ab8105 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -25,6 +25,8 @@ import Data.Foldable (traverse_) import Data.Maybe (fromMaybe) import Data.IntMap.Lazy qualified as IM import Data.Text qualified as T +import Data.HashSet qualified as HS +import Data.Hashable (hash) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment qualified as E @@ -33,9 +35,6 @@ import Language.PureScript.TypeChecker.Kinds (elaborateKind, instantiateKind, un import Language.PureScript.TypeChecker.Monad (CheckState(..), Substitution(..), UnkLevel(..), Unknown, getLocalContext, guardWith, lookupUnkName, withErrorMessageHint, TypeCheckM) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.Types (Constraint(..), pattern REmptyKinded, RowListItem(..), SourceType, Type(..), WildcardData(..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown, Hashed(..)) -import Data.HashSet qualified as HS -import Data.IntSet qualified as IntSet -import Data.Hashable (hash) -- | Generate a fresh type variable with an unknown kind. Avoid this if at all possible. freshType :: TypeCheckM SourceType diff --git a/tests/TestAst.hs b/tests/TestAst.hs index 4ec8b460b4..a916e2a452 100644 --- a/tests/TestAst.hs +++ b/tests/TestAst.hs @@ -73,7 +73,7 @@ genTypeAnnotatedWith genTypeAnn genConstraintAnn = genType where genConstraintData :: Gen ConstraintData genConstraintData = genericArbitraryUG generatorEnvironment - genQualified :: forall b. Hashable b => Show b => (Text -> b) -> Gen (Qualified b) + genQualified :: forall b. Hashable b => (Text -> b) -> Gen (Qualified b) genQualified ctor = mkQualified_ ByNullSourcePos . ctor <$> genText genSkolemScope :: Gen SkolemScope From 2773298042b55cb78b7ed0faa04f679c559fd67b Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Wed, 28 May 2025 11:36:31 +0000 Subject: [PATCH 16/19] Fix type search ordering and tests --- src/Language/PureScript/Errors.hs | 2 +- src/Language/PureScript/Names.hs | 4 +++- src/Language/PureScript/TypeChecker/TypeSearch.hs | 8 ++++---- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 21304fee01..a98d58e655 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1157,7 +1157,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon (Box.alignHoriz Box.left longestId <$> idBoxes) tyBoxes in [ line "You could substitute the hole with one of these values:" - , markCodeBox (indent (formatTS (unzip (take maxTSResults idents)))) + , markCodeBox (indent (formatTS (unzip (take maxTSResults (idents))))) ] _ -> [] in diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 5889bc2297..436250d69c 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -271,7 +271,9 @@ instance (Serialise a) => Serialise (Qualified' a) newtype Qualified a = QualifiedCons (HashCons (Qualified' a)) deriving (Show, Eq, Generic) - deriving newtype (Ord) -- TODO: ORD? + +instance (Eq a, Ord a) => Ord (Qualified a) where + compare (QualifiedCons q1) (QualifiedCons q2) = compare (unHashCons q1) (unHashCons q2) instance (NFData a) => NFData (Qualified a) diff --git a/src/Language/PureScript/TypeChecker/TypeSearch.hs b/src/Language/PureScript/TypeChecker/TypeSearch.hs index 4be101bc03..84295518da 100644 --- a/src/Language/PureScript/TypeChecker/TypeSearch.hs +++ b/src/Language/PureScript/TypeChecker/TypeSearch.hs @@ -121,14 +121,14 @@ typeSearch unsolved env st type' = runTypeSearch :: HM.HashMap k P.SourceType -> HM.HashMap k P.SourceType runTypeSearch = HM.mapMaybe (\ty -> checkSubsume unsolved env st type' ty $> ty) - matchingNames = runTypeSearch (HM.map (\(ty, _, _) -> ty) (P.names env)) - matchingConstructors = runTypeSearch (HM.map (\(_, _, ty, _) -> ty) (P.dataConstructors env)) + matchingNames = sortOn fst $ HM.toList $ runTypeSearch (fmap (\(ty, _, _) -> ty) (P.names env)) + matchingConstructors = sortOn fst $ HM.toList $ runTypeSearch (fmap (\(_, _, ty, _) -> ty) (P.dataConstructors env)) (allLabels, matchingLabels) = accessorSearch unsolved env st type' runPlainIdent (Qualified m (Ident k), v) = Just (Qualified m k, v) runPlainIdent _ = Nothing in ( (first (P.mkQualified_ P.ByNullSourcePos . ("_." <>) . P.prettyPrintLabel) <$> matchingLabels) - <> mapMaybe runPlainIdent (HM.toList matchingNames) - <> (first (mapQualified P.runProperName) <$> HM.toList matchingConstructors) + <> mapMaybe runPlainIdent matchingNames + <> (first (mapQualified P.runProperName) <$> matchingConstructors) , if null allLabels then Nothing else Just allLabels) From e86c6c15dbc4155082842680cb3b1139bf0c06c6 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Wed, 28 May 2025 12:54:22 +0000 Subject: [PATCH 17/19] Lint error --- src/Language/PureScript/Interner.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Interner.hs b/src/Language/PureScript/Interner.hs index 7f3b28fc71..d84ce67aac 100644 --- a/src/Language/PureScript/Interner.hs +++ b/src/Language/PureScript/Interner.hs @@ -81,7 +81,7 @@ instance Eq a => Eq (HashCons a) where | ref1 == ref2 = True | h1 /= h2 = False | otherwise = compareAndSubstitute ((==) :: a -> a -> Bool) True ref1 ref2 - {- INLINE (==) #-} + {-# INLINE (==) #-} -- | NOTE: This instance orders by hash first, and only secondarily by -- the 'Ord' instance of 'a', to improve performance. From 1a183bd11535d96e0fd87afd38657d2470dc15d2 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Wed, 28 May 2025 13:34:26 +0000 Subject: [PATCH 18/19] Lint error --- src/Language/PureScript/Errors.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index a98d58e655..21304fee01 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -1157,7 +1157,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath fileCon (Box.alignHoriz Box.left longestId <$> idBoxes) tyBoxes in [ line "You could substitute the hole with one of these values:" - , markCodeBox (indent (formatTS (unzip (take maxTSResults (idents))))) + , markCodeBox (indent (formatTS (unzip (take maxTSResults idents)))) ] _ -> [] in From 9d098fb5fd8bacfd9101a4e4c541ba2182a61963 Mon Sep 17 00:00:00 2001 From: Michal Kozakiewicz Date: Wed, 28 May 2025 21:02:44 +0000 Subject: [PATCH 19/19] Remove perf.txt --- perf.txt | 8 -------- 1 file changed, 8 deletions(-) delete mode 100644 perf.txt diff --git a/perf.txt b/perf.txt deleted file mode 100644 index 1fb17f7e30..0000000000 --- a/perf.txt +++ /dev/null @@ -1,8 +0,0 @@ -# HashCons - -stat A: min 15ms max 16ms mean 16ms median 16ms stddev 0ms n=14 -stat B: min 13ms max 14ms mean 14ms median 14ms stddev 0ms n=14 -mean diff -13.4% -ttest detected diff? true p-value 0.000000 -stat ratios: min -14.90% max -10.91% mean -13.35% median -13.25% stddev 0.94% n=14 -ttest detected ratios diff? true p-value 0.000000