module Language.PureScript.Sugar.Names (
desugarImports
) where
import Data.List (find, nub, (\\))
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
import Control.Applicative (Applicative(..), (<$>), (<*>))
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import qualified Data.Map as M
import Language.PureScript.AST
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Traversals
import qualified Language.PureScript.Constants as C
type ExportEnvironment = M.Map ModuleName Exports
data Exports = Exports
{
exportedTypes :: [(ProperName, [ProperName])]
, exportedTypeClasses :: [ProperName]
, exportedValues :: [Ident]
, exportedModules :: [ModuleName]
} deriving (Show)
data ImportEnvironment = ImportEnvironment
{
importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
, importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
, importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
, importedValues :: M.Map (Qualified Ident) (Qualified Ident)
} deriving (Show)
updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment
updateExportedModule env mn update = do
let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
exports' <- update exports
return $ M.insert mn exports' env
addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment
addEmptyModule env name =
if name `M.member` env
then throwError . errorMessage $ RedefinedModule name
else return $ M.insert name (Exports [] [] [] []) env
addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment
addType env mn name dctors = updateExportedModule env mn $ \m -> do
let exTypes = exportedTypes m
let exDctors = snd `concatMap` exTypes
let exClasses = exportedTypeClasses m
when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name
forM_ dctors $ \dctor -> do
when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor
return $ m { exportedTypes = (name, dctors) : exTypes }
addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment
addTypeClass env mn name = updateExportedModule env mn $ \m -> do
let exTypes = exportedTypes m
let exDctors = snd `concatMap` exTypes
when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name
when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
classes <- addExport DuplicateClassExport (exportedTypeClasses m) name
return $ m { exportedTypeClasses = classes }
addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment
addValue env mn name = updateExportedModule env mn $ \m -> do
values <- addExport DuplicateValueExport (exportedValues m) name
return $ m { exportedValues = values }
addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> SimpleErrorMessage) -> [a] -> a -> m [a]
addExport what exports name =
if name `elem` exports
then throwConflictError what name
else return $ name : exports
desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
desugarImports modules = do
unfilteredExports <- findExports modules
exports <- foldM filterModuleExports unfilteredExports modules
let modules' = moduleReexports <$> modules
mapM (renameInModule' unfilteredExports exports) modules'
where
moduleReexports :: Module -> Module
moduleReexports (Module coms mn decls exps) =
let importedMods = catMaybes findImports'
in (Module coms mn (decls ++ (concatMap reexports importedMods)) exps)
where
imports :: [Declaration]
imports = filter isImportDecl decls
findImports' :: [Maybe (Declaration, Module)]
findImports' = go <$> modules
where
go :: Module -> Maybe (Declaration, Module)
go m@(Module _ mn' _ (Just exps'))
| any isModExport exps', Just d <- find ((== mn') . importedModName) imports = Just (d, m)
where
importedModName :: Declaration -> ModuleName
importedModName (ImportDeclaration imn _ _) = imn
importedModName (PositionedDeclaration _ _ d) = importedModName d
importedModName _ = error "Not an import decl"
go _ = Nothing
reexports :: (Declaration, Module) -> [Declaration]
reexports (ImportDeclaration _ (Hiding refs) _, (Module coms' mn' ds' (Just exps'))) =
case nonHiddenRefs of
[] -> []
_ -> reexports (ImportDeclaration mn' Implicit Nothing, Module coms' mn' ds' (Just nonHiddenRefs))
where
nonHiddenRefs :: [DeclarationRef]
nonHiddenRefs = filter isModExport exps' \\ filter isModExport refs
reexports (ImportDeclaration _ ty qual, Module _ _ _ (Just exps')) =
let ty' = case ty of
Explicit _ -> Explicit []
_ -> ty
in (\m -> ImportDeclaration m ty' qual) <$> (catMaybes $ go <$> exps')
where
go :: DeclarationRef -> Maybe ModuleName
go (ModuleRef mn') = Just mn'
go _ = Nothing
reexports (PositionedDeclaration _ _ d, m@(Module _ _ _ (Just _))) = reexports (d, m)
reexports _ = []
isModExport :: DeclarationRef -> Bool
isModExport (ModuleRef _) = True
isModExport _ = False
filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment
filterModuleExports env (Module _ mn _ (Just exps))
| any isSelfModuleExport exps, Just exps' <- M.lookup mn env =
let moduleNames = filter (/= mn) $ (\(ModuleRef mn') -> mn') <$> filter isModExport exps
in return $ M.insert mn (exps' {exportedModules = moduleNames}) env
where
isSelfModuleExport :: DeclarationRef -> Bool
isSelfModuleExport (ModuleRef mn') | mn' == mn = True
isSelfModuleExport (PositionedDeclarationRef _ _ ref) = isSelfModuleExport ref
isSelfModuleExport _ = False
filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env
filterModuleExports env _ = return env
renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
renameInModule' unfilteredExports exports m@(Module _ mn _ _) =
rethrow (onErrorMessages (ErrorInModule mn)) $ do
let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
imports <- resolveImports env m
elaborateImports <$> renameInModule imports env (elaborateExports exps m)
elaborateExports :: Exports -> Module -> Module
elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $
map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
map TypeClassRef (exportedTypeClasses exps) ++
map ValueRef (exportedValues exps) ++
map ModuleRef (exportedModules exps))
elaborateImports :: Module -> Module
elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
where
decls' :: [Declaration]
decls' =
let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
in mkImport `map` nub (f `concatMap` decls) ++ decls
fqValues :: Expr -> [ModuleName]
fqValues (Var (Qualified (Just mn') _)) = [mn']
fqValues _ = []
mkImport :: ModuleName -> Declaration
mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing
renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
renameInModule imports exports (Module coms mn decls exps) =
Module coms mn <$> parU decls go <*> pure exps
where
(go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)
updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
(,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
(,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
(,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
(,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)
updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =
(,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)
updateDecl (pos, bound) (TypeDeclaration name ty) =
(,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
updateDecl (pos, bound) (ExternDeclaration name ty) =
(,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty)
updateDecl s d = return (s, d)
updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)
updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
updateValue (pos, bound) (Let ds val') = do
let args = mapMaybe letBoundVariable ds
unless (length (nub args) == length args) $
maybe id rethrowWithPosition pos $
throwError . errorMessage $ OverlappingNamesInLet
return ((pos, args ++ bound), Let ds val')
where
updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
(,) (pos, bound) <$> (Var <$> updateValueName name' pos)
updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
(,) (pos, bound) <$> (Var <$> updateValueName name' pos)
updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
updateValue s v = return (s, v)
updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)
updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
updateBinder s v = return (s, v)
updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
letBoundVariable :: Declaration -> Maybe Ident
letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d
letBoundVariable _ = Nothing
updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type
updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
where
updateType :: Maybe SourceSpan -> Type -> m Type
updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
updateType _ t = return t
updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)
updateValueName = update UnknownValue importedValues (flip elem . exportedValues)
updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
update :: (Ord a, Show a) => (Qualified a -> SimpleErrorMessage)
-> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
-> (Exports -> a -> Bool)
-> Qualified a
-> Maybe SourceSpan
-> m (Qualified a)
update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
(Just qname', _) -> return qname'
(Nothing, Just mn'') -> do
when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
modExports <- getExports mn''
if checkE modExports name
then return qname
else throwError . errorMessage $ unknown qname
_ -> throwError . errorMessage $ unknown qname
where
isExplicitQualModule :: ModuleName -> Bool
isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
imports' = getI imports
positioned err = case pos of
Nothing -> err
Just pos' -> rethrowWithPosition pos' err
getExports :: ModuleName -> m Exports
getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports
findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment
findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
where
primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] [] []
where
mkTypeEntry (Qualified _ name) = (name, [])
addModule :: ExportEnvironment -> Module -> m ExportEnvironment
addModule env (Module _ mn ds _) = do
env' <- addEmptyModule env mn
rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds
addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment
addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
env' <- addTypeClass env mn tcn
foldM go env' ds
where
go env'' (TypeDeclaration name _) = addValue env'' mn name
go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d
go _ _ = error "Invalid declaration in TypeClassDeclaration"
addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
addDecl mn env (ExternDeclaration name _) = addValue env mn name
addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
addDecl _ env _ = return env
filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment
filterExports mn exps env = do
let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports
return $ M.insert mn moduleExports' env
where
filterModule :: Exports -> m Exports
filterModule exported = do
types' <- foldM (filterTypes $ exportedTypes exported) [] exps
values <- foldM (filterValues $ exportedValues exported) [] exps
classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
modules <- foldM (filterModules $ exportedModules exported) [] exps
return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values, exportedModules = modules }
filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]
filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
filterTypes expTys result (TypeRef name expDcons) = do
dcons <- maybe (throwError . errorMessage . UnknownType $ Qualified (Just mn) name) return $ name `lookup` expTys
dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
return $ (name, dcons') : result
filterTypes _ result _ = return result
filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]
filterDcons tcon exps' result name =
if name `elem` exps'
then return $ name : result
else throwError . errorMessage $ UnknownDataConstructor (Qualified (Just mn) name) (Just (Qualified (Just mn) tcon))
filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]
filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
filterClasses exps' result (TypeClassRef name) =
if name `elem` exps'
then return $ name : result
else throwError . errorMessage . UnknownTypeClass $ Qualified (Just mn) name
filterClasses _ result _ = return result
filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]
filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r
filterValues exps' result (ValueRef name) =
if name `elem` exps'
then return $ name : result
else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name
filterValues _ result _ = return result
filterModules :: [ModuleName] -> [ModuleName] -> DeclarationRef -> m [ModuleName]
filterModules exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterModules exps' result r
filterModules _ result (ModuleRef name) = return $ name : result
filterModules _ result _ = return result
findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
findImports = foldl (findImports' Nothing) M.empty
where
findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d
findImports' _ result _ = result
resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment
resolveImports env (Module _ currentModule decls _) =
foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
where
scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
scope = M.insert currentModule (Nothing, Implicit, Nothing) (findImports decls)
resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment
resolveImport' imp (mn, (pos, typ, impQual)) = do
modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env
positioned $ resolveImport currentModule mn modExports imp impQual typ
where
positioned err = case pos of
Nothing -> err
Just pos' -> rethrowWithPosition pos' err
resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment
resolveImport currentModule importModule exps imps impQual =
resolveByType
where
resolveByType :: ImportDeclarationType -> m ImportEnvironment
resolveByType Implicit = importAll importExplicit
resolveByType (Explicit explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
resolveByType (Hiding hiddenImports) = do
hiddenImports' <- checkedRefs hiddenImports
importAll (importNonHidden hiddenImports')
importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment
importNonHidden hidden m ref =
if isHidden hidden ref
then return m
else importExplicit m ref
isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
isHidden hidden ref@(TypeRef _ _) =
let
checkTypeRef _ True _ = True
checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
checkTypeRef _ acc _ = acc
in foldl (checkTypeRef ref) False hidden
isHidden hidden ref = ref `elem` hidden
importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment
importAll importer = do
imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment
importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r
importExplicit imp (ValueRef name) = do
values' <- updateImports (importedValues imp) name
return $ imp { importedValues = values' }
importExplicit imp (TypeRef name dctors) = do
types' <- updateImports (importedTypes imp) name
let allDctors = allExportedDataConstructors name
dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
importExplicit imp (TypeClassRef name) = do
typeClasses' <- updateImports (importedTypeClasses imp) name
return $ imp { importedTypeClasses = typeClasses' }
importExplicit _ _ = error "Invalid argument to importExplicit"
checkedRefs :: [DeclarationRef] -> m [DeclarationRef]
checkedRefs = mapM check
where
check (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos $ check r
check ref@(ValueRef name) =
checkImportExists UnknownValue values name >> return ref
check ref@(TypeRef name dctors) = do
_ <- checkImportExists UnknownType availableTypes name
let allDctors = allExportedDataConstructors name
_ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
return ref
check ref@(TypeClassRef name) =
checkImportExists UnknownTypeClass classes name >> return ref
check ref@(ModuleRef name) =
checkImportExists (UnknownModule . (\(Qualified _ m) -> m)) (exportedModules exps) name >> return ref
check _ = error "Invalid argument to checkRefIsValid"
allExportedDataConstructors :: ProperName -> [ProperName]
allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))
updateImports m name = case M.lookup (Qualified impQual name) m of
Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
Just (Qualified Nothing _) -> error "Invalid state in updateImports"
Just (Qualified (Just mn) _) -> throwError . errorMessage $ err
where
err = if currentModule `elem` [mn, importModule]
then ConflictingImport (show name) importModule
else ConflictingImports (show name) mn importModule
values = exportedValues exps
availableTypes = fst `map` exportedTypes exps
classes = exportedTypeClasses exps
checkDctorExists :: [ProperName] -> ProperName -> m ProperName
checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)
checkImportExists :: (Eq a, Show a) => (Qualified a -> SimpleErrorMessage) -> [a] -> a -> m a
checkImportExists unknown exports item =
if item `elem` exports
then return item
else throwError . errorMessage . unknown $ Qualified (Just importModule) item
throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> SimpleErrorMessage) -> a -> m b
throwConflictError conflict = throwError . errorMessage . conflict