module Language.PureScript.Sugar.Names.Env
( ImportRecord(..)
, ImportProvenance(..)
, Imports(..)
, nullImports
, Exports(..)
, nullExports
, Env
, primEnv
, primExports
, envModuleSourceSpan
, envModuleImports
, envModuleExports
, ExportMode(..)
, exportType
, exportTypeOp
, exportTypeClass
, exportValue
, exportValueOp
, exportKind
, getExports
, checkImportConflicts
) where
import Prelude.Compat
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Function (on)
import Data.Foldable (find)
import Data.List (groupBy, sortBy, delete)
import Data.Maybe (fromJust, mapMaybe)
import Safe (headMay)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Language.PureScript.Constants as C
import Language.PureScript.AST
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Names
data ImportRecord a =
ImportRecord
{ importName :: Qualified a
, importSourceModule :: ModuleName
, importSourceSpan :: SourceSpan
, importProvenance :: ImportProvenance
}
deriving (Eq, Ord, Show)
data ImportProvenance
= FromImplicit
| FromExplicit
| Local
| Prim
deriving (Eq, Ord, Show)
type ImportMap a = M.Map (Qualified a) [ImportRecord a]
data Imports = Imports
{
importedTypes :: ImportMap (ProperName 'TypeName)
, importedTypeOps :: ImportMap (OpName 'TypeOpName)
, importedDataConstructors :: ImportMap (ProperName 'ConstructorName)
, importedTypeClasses :: ImportMap (ProperName 'ClassName)
, importedValues :: ImportMap Ident
, importedValueOps :: ImportMap (OpName 'ValueOpName)
, importedModules :: S.Set ModuleName
, importedQualModules :: S.Set ModuleName
, importedKinds :: ImportMap (ProperName 'KindName)
} deriving (Show)
nullImports :: Imports
nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty M.empty
data Exports = Exports
{
exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ExportSource)
, exportedTypeOps :: M.Map (OpName 'TypeOpName) ExportSource
, exportedTypeClasses :: M.Map (ProperName 'ClassName) ExportSource
, exportedValues :: M.Map Ident ExportSource
, exportedValueOps :: M.Map (OpName 'ValueOpName) ExportSource
, exportedKinds :: M.Map (ProperName 'KindName) ExportSource
} deriving (Show)
nullExports :: Exports
nullExports = Exports M.empty M.empty M.empty M.empty M.empty M.empty
type Env = M.Map ModuleName (SourceSpan, Imports, Exports)
envModuleSourceSpan :: (SourceSpan, a, b) -> SourceSpan
envModuleSourceSpan (ss, _, _) = ss
envModuleImports :: (a, Imports, b) -> Imports
envModuleImports (_, imps, _) = imps
envModuleExports :: (a, b, Exports) -> Exports
envModuleExports (_, _, exps) = exps
primExports :: Exports
primExports = mkPrimExports primTypes primClasses primKinds
primBooleanExports :: Exports
primBooleanExports = mkPrimExports primBooleanTypes mempty primBooleanKinds
primOrderingExports :: Exports
primOrderingExports = mkPrimExports primOrderingTypes mempty primOrderingKinds
primRowExports :: Exports
primRowExports = mkPrimExports primRowTypes primRowClasses mempty
primRowListExports :: Exports
primRowListExports = mkPrimExports primRowListTypes primRowListClasses primRowListKinds
primSymbolExports :: Exports
primSymbolExports = mkPrimExports primSymbolTypes primSymbolClasses mempty
primTypeErrorExports :: Exports
primTypeErrorExports = mkPrimExports primTypeErrorTypes primTypeErrorClasses primTypeErrorKinds
mkPrimExports
:: M.Map (Qualified (ProperName 'TypeName)) a
-> M.Map (Qualified (ProperName 'ClassName)) b
-> S.Set (Qualified (ProperName 'KindName))
-> Exports
mkPrimExports ts cs ks =
nullExports
{ exportedTypes = M.fromList $ mkTypeEntry `map` M.keys ts
, exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys cs
, exportedKinds = M.fromList $ mkKindEntry `map` S.toList ks
}
where
mkTypeEntry (Qualified mn name) = (name, ([], primExportSource mn))
mkClassEntry (Qualified mn name) = (name, primExportSource mn)
mkKindEntry (Qualified mn name) = (name, primExportSource mn)
primExportSource mn =
ExportSource
{ exportSourceImportedFrom = Nothing
, exportSourceDefinedIn = fromJust mn
}
primEnv :: Env
primEnv = M.fromList
[ ( C.Prim
, (internalModuleSourceSpan "<Prim>", nullImports, primExports)
)
, ( C.PrimBoolean
, (internalModuleSourceSpan "<Prim.Boolean>", nullImports, primBooleanExports)
)
, ( C.PrimOrdering
, (internalModuleSourceSpan "<Prim.Ordering>", nullImports, primOrderingExports)
)
, ( C.PrimRow
, (internalModuleSourceSpan "<Prim.Row>", nullImports, primRowExports)
)
, ( C.PrimRowList
, (internalModuleSourceSpan "<Prim.RowList>", nullImports, primRowListExports)
)
, ( C.PrimSymbol
, (internalModuleSourceSpan "<Prim.Symbol>", nullImports, primSymbolExports)
)
, ( C.PrimTypeError
, (internalModuleSourceSpan "<Prim.TypeError>", nullImports, primTypeErrorExports)
)
]
data ExportMode = Internal | ReExport
deriving (Eq, Show)
exportType
:: MonadError MultipleErrors m
=> SourceSpan
-> ExportMode
-> Exports
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ExportSource
-> m Exports
exportType ss exportMode exps name dctors src = do
let exTypes = exportedTypes exps
exClasses = exportedTypeClasses exps
dctorNameCounts :: [(ProperName 'ConstructorName, Int)]
dctorNameCounts = M.toList $ M.fromListWith (+) (map (,1) dctors)
forM_ dctorNameCounts $ \(dctorName, count) ->
when (count > 1) $
throwDeclConflict (DctorName dctorName) (DctorName dctorName)
case exportMode of
Internal -> do
when (name `M.member` exTypes) $
throwDeclConflict (TyName name) (TyName name)
when (coerceProperName name `M.member` exClasses) $
throwDeclConflict (TyName name) (TyClassName (coerceProperName name))
forM_ dctors $ \dctor -> do
when ((elem dctor . fst) `any` exTypes) $
throwDeclConflict (DctorName dctor) (DctorName dctor)
when (coerceProperName dctor `M.member` exClasses) $
throwDeclConflict (DctorName dctor) (TyClassName (coerceProperName dctor))
ReExport -> do
let mn = exportSourceDefinedIn src
forM_ (coerceProperName name `M.lookup` exClasses) $ \src' ->
let mn' = exportSourceDefinedIn src' in
throwExportConflict' ss mn mn' (TyName name) (TyClassName (coerceProperName name))
forM_ (name `M.lookup` exTypes) $ \(_, src') ->
let mn' = exportSourceDefinedIn src' in
when (mn /= mn') $
throwExportConflict ss mn mn' (TyName name)
forM_ dctors $ \dctor ->
forM_ ((elem dctor . fst) `find` exTypes) $ \(_, src') ->
let mn' = exportSourceDefinedIn src' in
when (mn /= mn') $
throwExportConflict ss mn mn' (DctorName dctor)
return $ exps { exportedTypes = M.alter updateOrInsert name exTypes }
where
updateOrInsert Nothing = Just (dctors, src)
updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', src)
exportTypeOp
:: MonadError MultipleErrors m
=> SourceSpan
-> Exports
-> OpName 'TypeOpName
-> ExportSource
-> m Exports
exportTypeOp ss exps op src = do
typeOps <- addExport ss TyOpName op src (exportedTypeOps exps)
return $ exps { exportedTypeOps = typeOps }
exportTypeClass
:: MonadError MultipleErrors m
=> SourceSpan
-> ExportMode
-> Exports
-> ProperName 'ClassName
-> ExportSource
-> m Exports
exportTypeClass ss exportMode exps name src = do
let exTypes = exportedTypes exps
when (exportMode == Internal) $ do
when (coerceProperName name `M.member` exTypes) $
throwDeclConflict (TyClassName name) (TyName (coerceProperName name))
when ((elem (coerceProperName name) . fst) `any` exTypes) $
throwDeclConflict (TyClassName name) (DctorName (coerceProperName name))
classes <- addExport ss TyClassName name src (exportedTypeClasses exps)
return $ exps { exportedTypeClasses = classes }
exportValue
:: MonadError MultipleErrors m
=> SourceSpan
-> Exports
-> Ident
-> ExportSource
-> m Exports
exportValue ss exps name src = do
values <- addExport ss IdentName name src (exportedValues exps)
return $ exps { exportedValues = values }
exportValueOp
:: MonadError MultipleErrors m
=> SourceSpan
-> Exports
-> OpName 'ValueOpName
-> ExportSource
-> m Exports
exportValueOp ss exps op src = do
valueOps <- addExport ss ValOpName op src (exportedValueOps exps)
return $ exps { exportedValueOps = valueOps }
exportKind
:: MonadError MultipleErrors m
=> SourceSpan
-> Exports
-> ProperName 'KindName
-> ExportSource
-> m Exports
exportKind ss exps name src = do
kinds <- addExport ss KiName name src (exportedKinds exps)
return $ exps { exportedKinds = kinds }
addExport
:: (MonadError MultipleErrors m, Ord a)
=> SourceSpan
-> (a -> Name)
-> a
-> ExportSource
-> M.Map a ExportSource
-> m (M.Map a ExportSource)
addExport ss toName name src exports =
case M.lookup name exports of
Just src' ->
let
mn = exportSourceDefinedIn src
mn' = exportSourceDefinedIn src'
in
if mn == mn'
then return exports
else throwExportConflict ss mn mn' (toName name)
Nothing ->
return $ M.insert name src exports
throwDeclConflict
:: MonadError MultipleErrors m
=> Name
-> Name
-> m a
throwDeclConflict new existing =
throwError . errorMessage $ DeclConflict new existing
throwExportConflict
:: MonadError MultipleErrors m
=> SourceSpan
-> ModuleName
-> ModuleName
-> Name
-> m a
throwExportConflict ss new existing name =
throwExportConflict' ss new existing name name
throwExportConflict'
:: MonadError MultipleErrors m
=> SourceSpan
-> ModuleName
-> ModuleName
-> Name
-> Name
-> m a
throwExportConflict' ss new existing newName existingName =
throwError . errorMessage' ss $
ExportConflict (Qualified (Just new) newName) (Qualified (Just existing) existingName)
getExports :: MonadError MultipleErrors m => Env -> ModuleName -> m Exports
getExports env mn =
maybe
(throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn)
(return . envModuleExports)
$ M.lookup mn env
checkImportConflicts
:: forall m a
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> SourceSpan
-> ModuleName
-> (a -> Name)
-> [ImportRecord a]
-> m (ModuleName, ModuleName)
checkImportConflicts ss currentModule toName xs =
let
byOrig = sortBy (compare `on` importSourceModule) xs
groups = groupBy ((==) `on` importSourceModule) byOrig
nonImplicit = filter ((/= FromImplicit) . importProvenance) xs
name = toName . disqualify . importName $ head xs
conflictModules = mapMaybe (getQual . importName . head) groups
in
if length groups > 1
then case nonImplicit of
[ImportRecord (Qualified (Just 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
return (mnNew, mnOrig)
_ -> throwError . errorMessage' ss $ ScopeConflict name conflictModules
else
let ImportRecord (Qualified (Just mnNew) _) mnOrig _ _ = head byOrig
in return (mnNew, mnOrig)