module Language.PureScript.Sugar.Names.Env
( ImportRecord(..)
, ImportProvenance(..)
, Imports(..)
, nullImports
, Exports(..)
, nullExports
, Env
, primEnv
, envModuleSourceSpan
, envModuleImports
, envModuleExports
, exportType
, exportTypeClass
, exportValue
, getExports
, checkImportConflicts
) where
import Data.Function (on)
import Data.List (groupBy, sortBy, nub, delete)
import Data.Maybe (fromJust)
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Names
import Language.PureScript.Environment
import Language.PureScript.Errors
data ImportRecord a =
ImportRecord
{ importName :: Qualified a
, importSourceModule :: ModuleName
, importProvenance :: ImportProvenance
}
deriving (Eq, Ord, Show, Read)
data ImportProvenance
= FromImplicit
| FromExplicit
| Local
deriving (Eq, Ord, Show, Read)
data Imports = Imports
{
importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [ImportRecord (ProperName 'TypeName)]
, importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [ImportRecord (ProperName 'ConstructorName)]
, importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [ImportRecord (ProperName 'ClassName)]
, importedValues :: M.Map (Qualified Ident) [ImportRecord Ident]
, importedModules :: S.Set ModuleName
, importedVirtualModules :: S.Set ModuleName
} deriving (Show, Read)
nullImports :: Imports
nullImports = Imports M.empty M.empty M.empty M.empty S.empty S.empty
data Exports = Exports
{
exportedTypes :: [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
, exportedTypeClasses :: [(ProperName 'ClassName, ModuleName)]
, exportedValues :: [(Ident, ModuleName)]
} deriving (Show, Read)
nullExports :: Exports
nullExports = Exports [] [] []
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 = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []
where
mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)
mkClassEntry (Qualified mn name) = (name, fromJust mn)
primEnv :: Env
primEnv = M.singleton
(ModuleName [ProperName "Prim"])
(internalModuleSourceSpan "<Prim>", nullImports, primExports)
exportType :: (MonadError MultipleErrors m) => Exports -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ModuleName -> m Exports
exportType exps name dctors mn = do
let exTypes' = exportedTypes exps
let exTypes = filter ((/= mn) . snd) exTypes'
let exDctors = (snd . fst) `concatMap` exTypes
let exClasses = exportedTypeClasses exps
when (any ((== name) . fst . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
when (any ((== coerceProperName name) . fst) exClasses) $ throwConflictError TypeConflictsWithClass name
forM_ dctors $ \dctor -> do
when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
when (any ((== coerceProperName dctor) . fst) exClasses) $ throwConflictError CtorConflictsWithClass dctor
return $ exps { exportedTypes = nub $ ((name, dctors), mn) : exTypes' }
exportTypeClass :: (MonadError MultipleErrors m) => Exports -> ProperName 'ClassName -> ModuleName -> m Exports
exportTypeClass exps name mn = do
let exTypes = exportedTypes exps
let exDctors = (snd . fst) `concatMap` exTypes
when (any ((== coerceProperName name) . fst . fst) exTypes) $ throwConflictError ClassConflictsWithType name
when (coerceProperName name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
classes <- addExport DuplicateClassExport name mn (exportedTypeClasses exps)
return $ exps { exportedTypeClasses = classes }
exportValue :: (MonadError MultipleErrors m) => Exports -> Ident -> ModuleName -> m Exports
exportValue exps name mn = do
values <- addExport DuplicateValueExport name mn (exportedValues exps)
return $ exps { exportedValues = values }
addExport :: (MonadError MultipleErrors m, Eq a) => (a -> SimpleErrorMessage) -> a -> ModuleName -> [(a, ModuleName)] -> m [(a, ModuleName)]
addExport what name mn exports =
if any (\(name', mn') -> name == name' && mn /= mn') exports
then throwConflictError what name
else return $ nub $ (name, mn) : exports
throwConflictError :: (MonadError MultipleErrors m) => (a -> SimpleErrorMessage) -> a -> m b
throwConflictError conflict = throwError . errorMessage . conflict
getExports :: (MonadError MultipleErrors m) => Env -> ModuleName -> m Exports
getExports env mn = maybe (throwError . errorMessage $ UnknownModule mn) (return . envModuleExports) $ M.lookup mn env
checkImportConflicts
:: forall m a
. (Show a, MonadError MultipleErrors m, MonadWriter MultipleErrors m, Ord a)
=> ModuleName
-> (a -> String)
-> [ImportRecord a]
-> m (ModuleName, ModuleName)
checkImportConflicts currentModule render xs =
let
byOrig = sortBy (compare `on` importSourceModule) xs
groups = groupBy ((==) `on` importSourceModule) byOrig
nonImplicit = filter ((/= FromImplicit) . importProvenance) xs
name = render' (importName . head $ xs)
conflictModules = map (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)
where
getQual :: Qualified a -> ModuleName
getQual (Qualified (Just mn) _) = mn
getQual _ = internalError "unexpected unqualified name in checkImportConflicts"
render' :: Qualified a -> String
render' (Qualified _ a) = render a