module Language.PureScript.AST.Exported
( exportedDeclarations
, isExported
) where
import Prelude.Compat
import Control.Category ((>>>))
import Data.Maybe (mapMaybe)
import Language.PureScript.AST.Declarations
import Language.PureScript.Types
import Language.PureScript.Names
exportedDeclarations :: Module -> [Declaration]
exportedDeclarations (Module _ _ mn decls exps) = go decls
where
go = flattenDecls
>>> filter (isExported exps)
>>> map (filterDataConstructors exps)
>>> filterInstances mn exps
filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration
filterDataConstructors exps (DataDeclaration sa dType tyName tyArgs dctors) =
DataDeclaration sa dType tyName tyArgs $
filter (isDctorExported tyName exps . fst) dctors
filterDataConstructors _ other = other
filterInstances
:: ModuleName
-> Maybe [DeclarationRef]
-> [Declaration]
-> [Declaration]
filterInstances _ Nothing = id
filterInstances mn (Just exps) =
let refs = Left `map` mapMaybe typeClassName exps
++ Right `map` mapMaybe typeName exps
in filter (all (visibleOutside refs) . typeInstanceConstituents)
where
visibleOutside
:: [Either (ProperName 'ClassName) (ProperName 'TypeName)]
-> Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))
-> Bool
visibleOutside refs q
| either checkQual checkQual q = True
| otherwise = either (Left . disqualify) (Right . disqualify) q `elem` refs
checkQual :: Qualified a -> Bool
checkQual q = isQualified q && not (isQualifiedWith mn q)
typeName :: DeclarationRef -> Maybe (ProperName 'TypeName)
typeName (TypeRef _ n _) = Just n
typeName _ = Nothing
typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)
typeClassName (TypeClassRef _ n) = Just n
typeClassName _ = Nothing
typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))]
typeInstanceConstituents (TypeInstanceDeclaration _ _ constraints className tys _) =
Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
where
fromConstraint c = Left (constraintClass c) : concatMap fromType (constraintArgs c)
fromType = everythingOnTypes (++) go
go (TypeConstructor n) = [Right n]
go (ConstrainedType c _) = fromConstraint c
go _ = []
typeInstanceConstituents _ = []
isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
isExported Nothing _ = True
isExported _ TypeInstanceDeclaration{} = True
isExported (Just exps) decl = any (matches decl) exps
where
matches (TypeDeclaration _ ident _) (ValueRef _ ident') = ident == ident'
matches (ValueDeclaration _ ident _ _ _) (ValueRef _ ident') = ident == ident'
matches (ExternDeclaration _ ident _) (ValueRef _ ident') = ident == ident'
matches (DataDeclaration _ _ ident _ _) (TypeRef _ ident' _) = ident == ident'
matches (ExternDataDeclaration _ ident _) (TypeRef _ ident' _) = ident == ident'
matches (ExternKindDeclaration _ ident) (KindRef _ ident') = ident == ident'
matches (TypeSynonymDeclaration _ ident _ _) (TypeRef _ ident' _) = ident == ident'
matches (TypeClassDeclaration _ ident _ _ _ _) (TypeClassRef _ ident') = ident == ident'
matches (ValueFixityDeclaration _ _ _ op) (ValueOpRef _ op') = op == op'
matches (TypeFixityDeclaration _ _ _ op) (TypeOpRef _ op') = op == op'
matches _ _ = False
isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool
isDctorExported _ Nothing _ = True
isDctorExported ident (Just exps) ctor = test `any` exps
where
test (TypeRef _ ident' Nothing) = ident == ident'
test (TypeRef _ ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
test _ = False