Filter.hs

-----------------------------------------------------------------------------
--
-- Module      : Language.PureScript.Ide.Filter
-- Description : Filters for psc-ide commands
-- Copyright   : Christoph Hegemann 2016
-- License     : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>
-- Stability   : experimental
--
-- |
-- Filters for psc-ide commands
-----------------------------------------------------------------------------

module Language.PureScript.Ide.Filter
       ( Filter
       , moduleFilter
       , namespaceFilter
       , exactFilter
       , prefixFilter
       , declarationTypeFilter
       , dependencyFilter
       , applyFilters
       ) where

import Protolude                     hiding (isPrefixOf, Prefix)

import Control.Monad.Fail (fail)
import Data.Aeson (FromJSON(..), withObject, (.:), (.:?))
import Data.Text (isPrefixOf)
import Data.Set qualified as Set
import Data.Map qualified as Map
import Language.PureScript.Ide.Filter.Declaration (DeclarationType)
import Language.PureScript.Ide.Types (IdeDeclarationAnn, IdeNamespace, ModuleMap, declarationType)
import Language.PureScript.Ide.Imports (Import, sliceImportSection)
import Language.PureScript.Ide.Util (discardAnn, identifierFromIdeDeclaration, namespaceForDeclaration)

import Language.PureScript qualified as P
import Data.Text qualified as T

import Language.PureScript.Ide.Filter.Imports (matchImport)

newtype Filter = Filter (Either (Set P.ModuleName) DeclarationFilter)
  deriving Show

unFilter :: Filter -> Either (Set P.ModuleName) DeclarationFilter
unFilter (Filter f) = f

data DeclarationFilter
  = Prefix Text
  | Exact Text
  | Namespace (Set IdeNamespace)
  | DeclType (Set DeclarationType)
  | Dependencies { qualifier :: Maybe P.ModuleName, currentModuleName :: P.ModuleName, dependencyImports :: [Import] }
  deriving Show

-- | Only keeps Declarations in the given modules
moduleFilter :: Set P.ModuleName -> Filter
moduleFilter = Filter . Left

-- | Only keeps Identifiers in the given Namespaces
namespaceFilter :: Set IdeNamespace -> Filter
namespaceFilter nss = Filter (Right (Namespace nss))

-- | Only keeps Identifiers that are equal to the search string
exactFilter :: Text -> Filter
exactFilter t = Filter (Right (Exact t))

-- | Only keeps Identifiers that start with the given prefix
prefixFilter :: Text -> Filter
prefixFilter t = Filter (Right (Prefix t))

-- | Only keeps Identifiers in the given type declarations
declarationTypeFilter :: Set DeclarationType -> Filter
declarationTypeFilter dts = Filter (Right (DeclType dts))

dependencyFilter :: Maybe P.ModuleName -> P.ModuleName -> [Import] -> Filter
dependencyFilter q m f = Filter (Right (Dependencies q m f))

optimizeFilters :: [Filter] -> (Maybe (Set P.ModuleName), [DeclarationFilter])
optimizeFilters = first smashModuleFilters . partitionEithers . map unFilter
  where
    smashModuleFilters [] =
      Nothing
    smashModuleFilters (x:xs) =
      Just (foldr Set.intersection x xs)

applyFilters :: [Filter] -> ModuleMap [IdeDeclarationAnn] -> ModuleMap [IdeDeclarationAnn]
applyFilters fs modules = case optimizeFilters fs of
  (Nothing, declarationFilters) ->
    applyDeclarationFilters declarationFilters modules
  (Just moduleFilter', declarationFilters) ->
    applyDeclarationFilters declarationFilters (Map.restrictKeys modules moduleFilter')

applyDeclarationFilters
  :: [DeclarationFilter]
  -> ModuleMap [IdeDeclarationAnn]
  -> ModuleMap [IdeDeclarationAnn]
applyDeclarationFilters fs =
  Map.filter (not . null)
  . Map.mapWithKey (\modl decls -> foldr (.) identity (map (applyDeclarationFilter modl) fs) decls)

applyDeclarationFilter
  :: P.ModuleName
  -> DeclarationFilter
  -> [IdeDeclarationAnn]
  -> [IdeDeclarationAnn]
applyDeclarationFilter modl f = case f of
  Prefix prefix -> prefixFilter' prefix
  Exact t -> exactFilter' t
  Namespace namespaces -> namespaceFilter' namespaces
  DeclType dts -> declarationTypeFilter' dts
  Dependencies qual currentModuleName imps -> dependencyFilter' modl qual currentModuleName imps

namespaceFilter' :: Set IdeNamespace -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
namespaceFilter' namespaces =
  filter (\decl -> namespaceForDeclaration (discardAnn decl) `elem` namespaces)

exactFilter' :: Text -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
exactFilter' search =
  filter (\decl -> identifierFromIdeDeclaration (discardAnn decl) == search)

prefixFilter' :: Text -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
prefixFilter' prefix =
  filter (\decl -> prefix `isPrefixOf` identifierFromIdeDeclaration (discardAnn decl))

declarationTypeFilter' :: Set DeclarationType -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
declarationTypeFilter' declTypes =
  filter (\decl -> declarationType (discardAnn decl) `Set.member` declTypes)

dependencyFilter' :: P.ModuleName -> Maybe P.ModuleName -> P.ModuleName -> [Import] -> [IdeDeclarationAnn] -> [IdeDeclarationAnn]
dependencyFilter' modl qual currentModuleName imports =
  if modl == currentModuleName && isNothing qual then
    identity
  else
    filter (\decl -> any (matchImport qual modl decl) imports)

instance FromJSON Filter where
  parseJSON = withObject "filter" $ \o -> do
    (filter' :: Text) <- o .: "filter"
    case filter' of
      "modules" -> do
        params <- o .: "params"
        modules <- map P.moduleNameFromString <$> params .: "modules"
        pure (moduleFilter (Set.fromList modules))
      "exact" -> do
        params <- o .: "params"
        search <- params .: "search"
        pure (exactFilter search)
      "prefix" -> do
        params <- o .: "params"
        search <- params .: "search"
        pure (prefixFilter search)
      "namespace" -> do
        params <- o .: "params"
        namespaces <- params .: "namespaces"
        pure (namespaceFilter (Set.fromList namespaces))
      "declarations" -> do
        declarations <- o .: "params"
        pure (declarationTypeFilter (Set.fromList declarations))
      "dependencies" -> do
        params <- o .: "params"
        moduleText <- params .: "moduleText"
        qualifier <- fmap P.moduleNameFromString <$> params .:? "qualifier"
        case sliceImportSection (T.lines moduleText) of
          Left err -> fail ("Couldn't parse module imports: " <> T.unpack err)
          Right (currentModuleName, _, imports, _ ) -> pure (dependencyFilter qualifier currentModuleName imports)
      s -> fail ("Unknown filter: " <> show s)