module Language.PureScript.Sugar.Names.Env
( ImportRecord(..)
, ImportProvenance(..)
, Imports(..)
, nullImports
, Exports(..)
, nullExports
, Env
, primEnv
, 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 qualified Data.Map as M
import qualified Data.Set as S
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
, 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], ModuleName)
, exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName
, exportedTypeClasses :: M.Map (ProperName 'ClassName) ModuleName
, exportedValues :: M.Map Ident ModuleName
, exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName
, exportedKinds :: M.Map (ProperName 'KindName) ModuleName
} 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 =
nullExports
{ exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes
, exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses
, exportedKinds = M.fromList $ mkKindEntry `map` S.toList primKinds
}
where
mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn))
mkClassEntry (Qualified mn name) = (name, fromJust mn)
mkKindEntry (Qualified mn name) = (name, fromJust mn)
primEnv :: Env
primEnv = M.singleton
(ModuleName [ProperName "Prim"])
(internalModuleSourceSpan "<Prim>", nullImports, primExports)
data ExportMode = Internal | ReExport
deriving (Eq, Show)
exportType
:: MonadError MultipleErrors m
=> ExportMode
-> Exports
-> ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ModuleName
-> m Exports
exportType exportMode exps name dctors mn = 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
forM_ (name `M.lookup` exTypes) $ \(_, mn') ->
when (mn /= mn') $
throwExportConflict mn mn' (TyName name)
forM_ dctors $ \dctor ->
forM_ ((elem dctor . fst) `find` exTypes) $ \(_, mn') ->
when (mn /= mn') $
throwExportConflict mn mn' (DctorName dctor)
return $ exps { exportedTypes = M.alter updateOrInsert name exTypes }
where
updateOrInsert Nothing = Just (dctors, mn)
updateOrInsert (Just (dctors', _)) = Just (dctors ++ dctors', mn)
exportTypeOp
:: MonadError MultipleErrors m
=> Exports
-> OpName 'TypeOpName
-> ModuleName
-> m Exports
exportTypeOp exps op mn = do
typeOps <- addExport TyOpName op mn (exportedTypeOps exps)
return $ exps { exportedTypeOps = typeOps }
exportTypeClass
:: MonadError MultipleErrors m
=> ExportMode
-> Exports
-> ProperName 'ClassName
-> ModuleName
-> m Exports
exportTypeClass exportMode exps name mn = 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 TyClassName name mn (exportedTypeClasses exps)
return $ exps { exportedTypeClasses = classes }
exportValue
:: MonadError MultipleErrors m
=> Exports
-> Ident
-> ModuleName
-> m Exports
exportValue exps name mn = do
values <- addExport IdentName name mn (exportedValues exps)
return $ exps { exportedValues = values }
exportValueOp
:: MonadError MultipleErrors m
=> Exports
-> OpName 'ValueOpName
-> ModuleName
-> m Exports
exportValueOp exps op mn = do
valueOps <- addExport ValOpName op mn (exportedValueOps exps)
return $ exps { exportedValueOps = valueOps }
exportKind
:: MonadError MultipleErrors m
=> Exports
-> ProperName 'KindName
-> ModuleName
-> m Exports
exportKind exps name mn = do
kinds <- addExport KiName name mn (exportedKinds exps)
return $ exps { exportedKinds = kinds }
addExport
:: (MonadError MultipleErrors m, Ord a)
=> (a -> Name)
-> a
-> ModuleName
-> M.Map a ModuleName
-> m (M.Map a ModuleName)
addExport toName name mn exports =
case M.lookup name exports of
Just mn'
| mn == mn' -> return exports
| otherwise -> throwExportConflict mn mn' (toName name)
Nothing ->
return $ M.insert name mn exports
throwDeclConflict
:: MonadError MultipleErrors m
=> Name
-> Name
-> m a
throwDeclConflict new existing =
throwError . errorMessage $ DeclConflict new existing
throwExportConflict
:: MonadError MultipleErrors m
=> ModuleName
-> ModuleName
-> Name
-> m a
throwExportConflict new existing name =
throwError . errorMessage $
ExportConflict (Qualified (Just new) name) (Qualified (Just existing) name)
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)
=> ModuleName
-> (a -> Name)
-> [ImportRecord a]
-> m (ModuleName, ModuleName)
checkImportConflicts 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
tell . errorMessage $ ScopeShadowing name warningModule $ delete mnNew conflictModules
return (mnNew, mnOrig)
_ -> throwError . errorMessage $ ScopeConflict name conflictModules
else
let ImportRecord (Qualified (Just mnNew) _) mnOrig _ = head byOrig
in return (mnNew, mnOrig)