Reexports.hs

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

module Language.PureScript.Ide.Reexports
  ( resolveReexports
  , prettyPrintReexportResult
  , reexportHasFailures
  , ReexportResult(..)
  -- for tests
  , resolveReexports'
  ) where

import Protolude hiding (moduleName)

import Control.Lens (set)
import Data.Map qualified as Map
import Language.PureScript qualified as P
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util (discardAnn)

-- | Contains the module with resolved reexports, and possible failures
data ReexportResult a
  = ReexportResult
  { reResolved :: a
  , reFailed   :: [(P.ModuleName, P.DeclarationRef)]
  } deriving (Show, Eq, Functor, Generic)

instance NFData a => NFData (ReexportResult a)

-- | Uses the passed formatter to format the resolved module, and adds possible
-- failures
prettyPrintReexportResult
  :: (a -> Text)
  -- ^ Formatter for the resolved result
  -> ReexportResult a
  -- ^ The Result to be pretty printed
  -> Text
prettyPrintReexportResult f ReexportResult{..}
  | null reFailed =
      "Successfully resolved reexports for " <> f reResolved
  | otherwise =
      "Failed to resolve reexports for "
      <> f reResolved
      <> foldMap (\(mn, ref) -> P.runModuleName mn <> show ref) reFailed

-- | Whether any Refs couldn't be resolved
reexportHasFailures :: ReexportResult a -> Bool
reexportHasFailures = not . null . reFailed

-- | Resolves Reexports for the given Modules, by looking up the reexported
-- values from the passed in DeclarationRefs
resolveReexports
  :: ModuleMap [(P.ModuleName, P.DeclarationRef)]
  -- ^ the references to resolve
  -> ModuleMap [IdeDeclarationAnn]
  -- ^ Modules to search for the reexported declarations
  -> ModuleMap (ReexportResult [IdeDeclarationAnn])
resolveReexports reexportRefs modules =
  Map.mapWithKey (\moduleName decls ->
                    maybe (ReexportResult decls [])
                      (map (decls <>) . resolveReexports' modules)
                      (Map.lookup moduleName reexportRefs)) modules

resolveReexports'
  :: ModuleMap [IdeDeclarationAnn]
  -> [(P.ModuleName, P.DeclarationRef)]
  -> ReexportResult [IdeDeclarationAnn]
resolveReexports' modules refs =
  ReexportResult (concat resolvedRefs) failedRefs
  where
    (failedRefs, resolvedRefs) = partitionEithers (resolveRef' <$> refs)
    resolveRef' x@(mn, r) = case Map.lookup mn modules of
      Nothing -> Left x
      Just decls' ->
        let
          setExportedFrom = set (idaAnnotation . annExportedFrom) . Just
        in
          bimap (mn,) (map (setExportedFrom mn)) (resolveRef decls' r)

resolveRef
  :: [IdeDeclarationAnn]
  -> P.DeclarationRef
  -> Either P.DeclarationRef [IdeDeclarationAnn]
resolveRef decls ref = case ref of
  P.TypeRef _ tn mdtors ->
    case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn))
         <|> findRef (anyOf (_IdeDeclTypeSynonym . ideSynonymName) (== tn)) of
      Nothing ->
        Left ref
      Just d -> Right $ d : case mdtors of
          Nothing ->
            -- If the dataconstructor field inside the TypeRef is Nothing, that
            -- means that all data constructors are exported, so we need to look
            -- those up ourselves
            findDtors tn
          Just dtors -> mapMaybe lookupDtor dtors
  P.ValueRef _ i ->
    findWrapped (anyOf (_IdeDeclValue . ideValueIdent) (== i))
  P.ValueOpRef _ name ->
    findWrapped (anyOf (_IdeDeclValueOperator . ideValueOpName) (== name))
  P.TypeOpRef _ name ->
    findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name))
  P.TypeClassRef _ name ->
    findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name))
  _ ->
    Left ref
  where
    findWrapped = maybe (Left ref) (Right . pure) . findRef
    findRef f = find (f . discardAnn) decls

    lookupDtor name =
      findRef (anyOf (_IdeDeclDataConstructor . ideDtorName) (== name))

    findDtors tn = filter (anyOf
                           (idaDeclaration
                            . _IdeDeclDataConstructor
                            . ideDtorTypeName) (== tn)) decls