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 dType tyName tyArgs dctors) =
DataDeclaration dType tyName tyArgs $
filter (isDctorExported tyName exps . fst) dctors
filterDataConstructors exps (PositionedDeclaration srcSpan coms d) =
PositionedDeclaration srcSpan coms (filterDataConstructors exps d)
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 (PositionedDeclarationRef _ _ r) = typeName r
typeName _ = Nothing
typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName)
typeClassName (TypeClassRef n) = Just n
typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r
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 (PositionedDeclaration _ _ d) = typeInstanceConstituents d
typeInstanceConstituents _ = []
isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
isExported Nothing _ = True
isExported _ TypeInstanceDeclaration{} = True
isExported exps (PositionedDeclaration _ _ d) = isExported exps d
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 (PositionedDeclaration _ _ d) r = d `matches` r
matches d (PositionedDeclarationRef _ _ r) = d `matches` r
matches _ _ = False
isDctorExported :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName 'ConstructorName -> Bool
isDctorExported _ Nothing _ = True
isDctorExported ident (Just exps) ctor = test `any` exps
where
test (PositionedDeclarationRef _ _ d) = test d
test (TypeRef ident' Nothing) = ident == ident'
test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
test _ = False