module Language.PureScript.AST.Exported
( exportedDeclarations
, isExported
) where
import Prelude.Compat
import Protolude (sortBy, on)
import Control.Category ((>>>))
import Data.Maybe (mapMaybe)
import qualified Data.Map as M
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
>>> maybe id reorder 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 exps
where
matches declRef = declName decl == Just (declRefName declRef)
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
reorder :: [DeclarationRef] -> [Declaration] -> [Declaration]
reorder refs =
sortBy (compare `on` refIndex)
where
refIndices =
M.fromList $ zip (map declRefName refs) [(0::Int)..]
refIndex decl =
declName decl >>= flip M.lookup refIndices