Intern Qualified, use HashMaps for type checking environment

purescript.cabal

@@ -167,8 +167,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,
@@ -342,6 +342,7 @@ library
     Language.PureScript.Make.Monad
     Language.PureScript.ModuleDependencies
     Language.PureScript.Names
+    Language.PureScript.Interner
     Language.PureScript.Options
     Language.PureScript.Pretty
     Language.PureScript.Pretty.Common

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)
@@ -27,12 +26,13 @@ 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, pattern Qualified, QualifiedBy(..), toMaybeModuleName)
 import Language.PureScript.Roles (Role)
 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

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 :: (Hashable a) => Qualified a -> Bool
   checkQual q = isQualified q && not (isQualifiedWith mn q)
 
   typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)

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"

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 =

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

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(..), pattern Qualified, QualifiedBy(..), byMaybeModuleName, Qualified)
 import Language.PureScript.Types (SourceType, Type(..))
 
 lam :: Ident -> Expr -> Expr

src/Language/PureScript/CST/Convert.hs

@@ -37,6 +37,8 @@ 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)
+import Language.PureScript.Names (mapQualified)
 
 comment :: Comment a -> Maybe C.Comment
 comment = \case
@@ -87,10 +89,10 @@ 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)
+qualified :: ( Hashable a) =>QualifiedName a -> N.Qualified a
+qualified q = N.mkQualified_ qb (qualName q)
   where
   qb = maybe N.ByNullSourcePos N.ByModuleName $ qualModule q
 
@@ -529,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 ->

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 }

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

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)

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, ProperName(..), Qualified(..), QualifiedBy(..), runIdent, runModuleName, showIdent, showQualified)
+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)
@@ -392,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 :: (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)

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, runProperName)
 
 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:

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)
 
 -- Core lib values
 

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(..), Qualified(..), QualifiedBy(..))
+import Language.PureScript.Names (Ident(..), ModuleName(..), ProperName(..), ProperNameType(..), pattern Qualified, Qualified, QualifiedBy(..))
 
 -- | Generate pattern synonyms corresponding to the provided PureScript
 -- declarations.
@@ -192,17 +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 = typedPatSyn (mkName $ cap prefix <> str)
-  [t| Qualified (ProperName $pnType) |]
-  [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str)) |]
+mkPnPat pnType mn prefix str =
+  typedPatSyn (mkName $ cap prefix <> str)
+    [t| Qualified (ProperName $pnType) |]
+    [p| Qualified (ByModuleName $(conP mn [])) (ProperName $(litP $ stringL str))|]
+
 
 -- M_Data_Foo -> "function" -> "foo" ->
 --   pattern I_functionFoo :: Qualified Ident
 --   pattern I_functionFoo = Qualified (ByModuleName M_Data_Foo) (Ident "foo")
 mkIdentDec :: VarToDec
-mkIdentDec mn prefix str = typedPatSyn (mkPrefixedName "I_" prefix str)
-  [t| Qualified Ident |]
-  [p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) |]
+mkIdentDec mn prefix str =
+  typedPatSyn (mkPrefixedName "I_" prefix str)
+    [t| Qualified Ident |]
+    [p| Qualified (ByModuleName $(conP mn [])) (Ident $(litP $ stringL str)) |]
 
 -- M_Data_Foo -> "function" -> "foo" ->
 --   pattern P_functionFoo :: forall a. (Eq a, IsString a) => (ModuleName, a)

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, pattern Qualified, QualifiedBy(..), freshIdent, runIdent, toMaybeModuleName, properNameFromString, Qualified, 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 (ProperName . 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"

src/Language/PureScript/CoreFn/Desugar.hs

@@ -23,11 +23,13 @@ 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(..), 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
 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
@@ -132,7 +134,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) =
@@ -209,12 +211,12 @@ 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]))
       -> (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 +242,7 @@ findQualModules decls =
   fqBinders (A.ConstructorBinder _ q _) = getQual' q
   fqBinders _ = []
 
-  getQual' :: Qualified a -> [ModuleName]
+  getQual' :: (Hashable a) => Qualified a -> [ModuleName]
   getQual' = maybe [] return . getQual
 
 -- | Desugars import declarations from AST to CoreFn representation.