module Language.PureScript.Sugar.Names.Env
( 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)
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 Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Names
import Language.PureScript.Environment
import Language.PureScript.Errors
data Imports = Imports
{
importedTypes :: M.Map (Qualified (ProperName 'TypeName)) [(Qualified (ProperName 'TypeName), ModuleName)]
, importedDataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) [(Qualified (ProperName 'ConstructorName), ModuleName)]
, importedTypeClasses :: M.Map (Qualified (ProperName 'ClassName)) [(Qualified (ProperName 'ClassName), ModuleName)]
, importedValues :: M.Map (Qualified Ident) [(Qualified Ident, ModuleName)]
, 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
. (MonadError MultipleErrors m, Ord a)
=> (a -> String)
-> [(Qualified a, ModuleName)]
-> m ()
checkImportConflicts render xs =
let byOrig = groupBy ((==) `on` snd) . sortBy (compare `on` snd) $ xs
in
if length byOrig > 1
then throwError . errorMessage $ ScopeConflict (render' (fst . head $ xs)) (map (getQual . fst . head) byOrig)
else return ()
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