module Language.PureScript.Sugar.Names.Exports
( findExportable
, resolveExports
) where
import Prelude.Compat
import Control.Monad
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Error.Class (MonadError(..))
import Data.Function (on)
import Data.Foldable (traverse_)
import Data.List (intersect, groupBy, sortBy)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Map as M
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Errors
import Language.PureScript.Names
import Language.PureScript.Sugar.Names.Env
import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs)
findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports
findExportable (Module _ _ mn ds _) =
rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds
where
updateExports :: Exports -> Declaration -> m Exports
updateExports exps (TypeClassDeclaration tcn _ _ _ ds') = do
exps' <- exportTypeClass Internal exps tcn mn
foldM go exps' ds'
where
go exps'' (TypeDeclaration name _) = exportValue exps'' name mn
go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d
go _ _ = internalError "Invalid declaration in TypeClassDeclaration"
updateExports exps (DataDeclaration _ tn _ dcs) =
exportType Internal exps tn (map fst dcs) mn
updateExports exps (TypeSynonymDeclaration tn _ _) =
exportType Internal exps tn [] mn
updateExports exps (ExternDataDeclaration tn _) =
exportType Internal exps tn [] mn
updateExports exps (ValueDeclaration name _ _ _) =
exportValue exps name mn
updateExports exps (ValueFixityDeclaration _ _ op) =
exportValueOp exps op mn
updateExports exps (TypeFixityDeclaration _ _ op) =
exportTypeOp exps op mn
updateExports exps (ExternDeclaration name _) =
exportValue exps name mn
updateExports exps (ExternKindDeclaration pn) =
exportKind exps pn mn
updateExports exps (PositionedDeclaration pos _ d) =
rethrowWithPosition pos $ updateExports exps d
updateExports exps _ = return exps
resolveExports
:: forall m
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Env
-> SourceSpan
-> ModuleName
-> Imports
-> Exports
-> [DeclarationRef]
-> m Exports
resolveExports env ss mn imps exps refs =
warnAndRethrow (addHint (ErrorInModule mn)) $ do
filtered <- filterModule mn exps refs
exps' <- foldM elaborateModuleExports filtered refs
warnDuplicateRefs ss DuplicateExportRef refs
return exps'
where
elaborateModuleExports :: Exports -> DeclarationRef -> m Exports
elaborateModuleExports result (PositionedDeclarationRef pos _ r) =
warnAndRethrowWithPosition pos $ elaborateModuleExports result r
elaborateModuleExports result (ModuleRef name) | name == mn = do
let types' = exportedTypes result `M.union` exportedTypes exps
let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps
let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps
let values' = exportedValues result `M.union` exportedValues exps
let valueOps' = exportedValueOps result `M.union` exportedValueOps exps
let kinds' = exportedKinds result `M.union` exportedKinds exps
return result
{ exportedTypes = types'
, exportedTypeOps = typeOps'
, exportedTypeClasses = classes'
, exportedValues = values'
, exportedValueOps = valueOps'
, exportedKinds = kinds'
}
elaborateModuleExports result (ModuleRef name) = do
let isPseudo = isPseudoModule name
when (not isPseudo && not (isImportedModule name))
. throwError . errorMessage . UnknownExport $ ModName name
reTypes <- extract isPseudo name TyName (importedTypes imps)
reTypeOps <- extract isPseudo name TyOpName (importedTypeOps imps)
reDctors <- extract isPseudo name DctorName (importedDataConstructors imps)
reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps)
reValues <- extract isPseudo name IdentName (importedValues imps)
reValueOps <- extract isPseudo name ValOpName (importedValueOps imps)
reKinds <- extract isPseudo name KiName (importedKinds imps)
foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors)
>>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps)
>>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses)
>>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues)
>>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps)
>>= flip (foldM (uncurry . exportKind)) (map resolveKind reKinds)
elaborateModuleExports result _ = return result
extract
:: Bool
-> ModuleName
-> (a -> Name)
-> M.Map (Qualified a) [ImportRecord a]
-> m [Qualified a]
extract useQual name toName = fmap (map (importName . head . snd)) . go . M.toList
where
go = filterM $ \(name', options) -> do
let isMatch = if useQual then isQualifiedWith name name' else any (checkUnqual name') options
when (isMatch && length options > 1) $ void $ checkImportConflicts mn toName options
return isMatch
checkUnqual name' ir = isUnqualified name' && isQualifiedWith name (importName ir)
isPseudoModule :: ModuleName -> Bool
isPseudoModule = testQuals M.keys
where
testQuals :: (forall a b. M.Map (Qualified a) b -> [Qualified a]) -> ModuleName -> Bool
testQuals f mn' = any (isQualifiedWith mn') (f (importedTypes imps))
|| any (isQualifiedWith mn') (f (importedDataConstructors imps))
|| any (isQualifiedWith mn') (f (importedTypeClasses imps))
|| any (isQualifiedWith mn') (f (importedValues imps))
|| any (isQualifiedWith mn') (f (importedValueOps imps))
|| any (isQualifiedWith mn') (f (importedKinds imps))
isImportedModule :: ModuleName -> Bool
isImportedModule = flip elem (importedModules imps)
resolveTypeExports
:: [Qualified (ProperName 'TypeName)]
-> [Qualified (ProperName 'ConstructorName)]
-> [((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)]
resolveTypeExports tctors dctors = map go tctors
where
go
:: Qualified (ProperName 'TypeName)
-> ((ProperName 'TypeName, [ProperName 'ConstructorName]), ModuleName)
go (Qualified (Just mn'') name) =
fromMaybe (internalError "Missing value in resolveTypeExports") $ do
exps' <- envModuleExports <$> mn'' `M.lookup` env
(dctors', mnOrig) <- name `M.lookup` exportedTypes exps'
let relevantDctors = mapMaybe (disqualifyFor (Just mn'')) dctors
return ((name, relevantDctors `intersect` dctors'), mnOrig)
go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"
resolveTypeOp :: Qualified (OpName 'TypeOpName) -> (OpName 'TypeOpName, ModuleName)
resolveTypeOp op
= splitQual
. fromMaybe (internalError "Missing value in resolveValue")
$ resolve exportedTypeOps op
resolveClass :: Qualified (ProperName 'ClassName) -> (ProperName 'ClassName, ModuleName)
resolveClass className
= splitQual
. fromMaybe (internalError "Missing value in resolveClass")
$ resolve exportedTypeClasses className
resolveValue :: Qualified Ident -> (Ident, ModuleName)
resolveValue ident
= splitQual
. fromMaybe (internalError "Missing value in resolveValue")
$ resolve exportedValues ident
resolveValueOp :: Qualified (OpName 'ValueOpName) -> (OpName 'ValueOpName, ModuleName)
resolveValueOp op
= splitQual
. fromMaybe (internalError "Missing value in resolveValueOp")
$ resolve exportedValueOps op
resolveKind :: Qualified (ProperName 'KindName) -> (ProperName 'KindName, ModuleName)
resolveKind kind
= splitQual
. fromMaybe (internalError "Missing value in resolveKind")
$ resolve exportedKinds kind
resolve
:: Ord a
=> (Exports -> M.Map a ModuleName)
-> Qualified a
-> Maybe (Qualified a)
resolve f (Qualified (Just mn'') a) = do
exps' <- envModuleExports <$> mn'' `M.lookup` env
mn''' <- a `M.lookup` f exps'
return $ Qualified (Just mn''') a
resolve _ _ = internalError "Unqualified value in resolve"
splitQual :: Qualified a -> (a, ModuleName)
splitQual (Qualified (Just mn'') a) = (a, mn'')
splitQual _ = internalError "Unqualified value in splitQual"
filterModule
:: forall m
. MonadError MultipleErrors m
=> ModuleName
-> Exports
-> [DeclarationRef]
-> m Exports
filterModule mn exps refs = do
types <- foldM filterTypes M.empty (combineTypeRefs refs)
typeOps <- foldM (filterExport TyOpName getTypeOpRef exportedTypeOps) M.empty refs
classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs
values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs
valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs
kinds <- foldM (filterExport KiName getKindRef exportedKinds) M.empty refs
return Exports
{ exportedTypes = types
, exportedTypeOps = typeOps
, exportedTypeClasses = classes
, exportedValues = values
, exportedValueOps = valueOps
, exportedKinds = kinds
}
where
combineTypeRefs :: [DeclarationRef] -> [DeclarationRef]
combineTypeRefs
= fmap (uncurry TypeRef)
. map (foldr1 $ \(tc, dcs1) (_, dcs2) -> (tc, liftM2 (++) dcs1 dcs2))
. groupBy ((==) `on` fst)
. sortBy (compare `on` fst)
. mapMaybe getTypeRef
filterTypes
:: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)
-> DeclarationRef
-> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName))
filterTypes result (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos $ filterTypes result r
filterTypes result (TypeRef name expDcons) =
case name `M.lookup` exportedTypes exps of
Nothing -> throwError . errorMessage . UnknownExport $ TyName name
Just (dcons, _) -> do
let expDcons' = fromMaybe dcons expDcons
traverse_ (checkDcon name dcons) expDcons'
return $ M.insert name (expDcons', mn) result
where
checkDcon
:: ProperName 'TypeName
-> [ProperName 'ConstructorName]
-> ProperName 'ConstructorName
-> m ()
checkDcon tcon dcons dcon =
unless (dcon `elem` dcons) $
throwError . errorMessage $ UnknownExportDataConstructor tcon dcon
filterTypes result _ = return result
filterExport
:: Ord a
=> (a -> Name)
-> (DeclarationRef -> Maybe a)
-> (Exports -> M.Map a ModuleName)
-> M.Map a ModuleName
-> DeclarationRef
-> m (M.Map a ModuleName)
filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) =
rethrowWithPosition pos $ filterExport toName get fromExps result r
filterExport toName get fromExps result ref
| Just name <- get ref =
case name `M.lookup` fromExps exps of
Just mn' | mn == mn' -> return $ M.insert name mn result
_ -> throwError . errorMessage . UnknownExport $ toName name
filterExport _ _ _ result _ = return result