module Language.PureScript.AST.Exported (
exportedDeclarations,
isExported
) where
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 _ _ decls exps) = go decls
where
go = flattenDecls
>>> filter (isExported exps)
>>> map (filterDataConstructors exps)
>>> filterInstances 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 :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]
filterInstances Nothing = id
filterInstances (Just exps) =
let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps
in filter (all (visibleOutside refs) . typeInstanceConstituents)
where
visibleOutside _ (Qualified (Just _) _) = True
visibleOutside refs (Qualified Nothing n) = any (== n) refs
typeName (TypeRef n _) = Just n
typeName (PositionedDeclarationRef _ _ r) = typeName r
typeName _ = Nothing
typeClassName (TypeClassRef n) = Just n
typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r
typeClassName _ = Nothing
typeInstanceConstituents :: Declaration -> [Qualified ProperName]
typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =
className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
where
fromConstraint (name, tys') = name : concatMap fromType tys'
fromType = everythingOnTypes (++) go
go (TypeConstructor n) = [n]
go (ConstrainedType cs _) = concatMap fromConstraint cs
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 (FixityDeclaration _ name) (ValueRef ident') = name == runIdent ident'
matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
matches (PositionedDeclaration _ _ d) r = d `matches` r
matches d (PositionedDeclarationRef _ _ r) = d `matches` r
matches _ _ = False
isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> 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