-----------------------------------------------------------------------------
--
-- 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
  { forall a. ReexportResult a -> a
reResolved :: a
  , forall a. ReexportResult a -> [(ModuleName, DeclarationRef)]
reFailed   :: [(P.ModuleName, P.DeclarationRef)]
  } deriving (Int -> ReexportResult a -> ShowS
forall a. Show a => Int -> ReexportResult a -> ShowS
forall a. Show a => [ReexportResult a] -> ShowS
forall a. Show a => ReexportResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReexportResult a] -> ShowS
$cshowList :: forall a. Show a => [ReexportResult a] -> ShowS
show :: ReexportResult a -> String
$cshow :: forall a. Show a => ReexportResult a -> String
showsPrec :: Int -> ReexportResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ReexportResult a -> ShowS
Show, ReexportResult a -> ReexportResult a -> Bool
forall a. Eq a => ReexportResult a -> ReexportResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReexportResult a -> ReexportResult a -> Bool
$c/= :: forall a. Eq a => ReexportResult a -> ReexportResult a -> Bool
== :: ReexportResult a -> ReexportResult a -> Bool
$c== :: forall a. Eq a => ReexportResult a -> ReexportResult a -> Bool
Eq, forall a b. a -> ReexportResult b -> ReexportResult a
forall a b. (a -> b) -> ReexportResult a -> ReexportResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ReexportResult b -> ReexportResult a
$c<$ :: forall a b. a -> ReexportResult b -> ReexportResult a
fmap :: forall a b. (a -> b) -> ReexportResult a -> ReexportResult b
$cfmap :: forall a b. (a -> b) -> ReexportResult a -> ReexportResult b
Functor, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ReexportResult a) x -> ReexportResult a
forall a x. ReexportResult a -> Rep (ReexportResult a) x
$cto :: forall a x. Rep (ReexportResult a) x -> ReexportResult a
$cfrom :: forall a x. ReexportResult a -> Rep (ReexportResult a) x
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 :: forall a. (a -> Text) -> ReexportResult a -> Text
prettyPrintReexportResult a -> Text
f ReexportResult{a
[(ModuleName, DeclarationRef)]
reFailed :: [(ModuleName, DeclarationRef)]
reResolved :: a
reFailed :: forall a. ReexportResult a -> [(ModuleName, DeclarationRef)]
reResolved :: forall a. ReexportResult a -> a
..}
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, DeclarationRef)]
reFailed =
      Text
"Successfully resolved reexports for " forall a. Semigroup a => a -> a -> a
<> a -> Text
f a
reResolved
  | Bool
otherwise =
      Text
"Failed to resolve reexports for "
      forall a. Semigroup a => a -> a -> a
<> a -> Text
f a
reResolved
      forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(ModuleName
mn, DeclarationRef
ref) -> ModuleName -> Text
P.runModuleName ModuleName
mn forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show DeclarationRef
ref) [(ModuleName, DeclarationRef)]
reFailed

-- | Whether any Refs couldn't be resolved
reexportHasFailures :: ReexportResult a -> Bool
reexportHasFailures :: forall a. ReexportResult a -> Bool
reexportHasFailures = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReexportResult a -> [(ModuleName, DeclarationRef)]
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 :: ModuleMap [(ModuleName, DeclarationRef)]
-> ModuleMap [IdeDeclarationAnn]
-> ModuleMap (ReexportResult [IdeDeclarationAnn])
resolveReexports ModuleMap [(ModuleName, DeclarationRef)]
reexportRefs ModuleMap [IdeDeclarationAnn]
modules =
  forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\ModuleName
moduleName [IdeDeclarationAnn]
decls ->
                    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> [(ModuleName, DeclarationRef)] -> ReexportResult a
ReexportResult [IdeDeclarationAnn]
decls [])
                      (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ([IdeDeclarationAnn]
decls forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleMap [IdeDeclarationAnn]
-> [(ModuleName, DeclarationRef)]
-> ReexportResult [IdeDeclarationAnn]
resolveReexports' ModuleMap [IdeDeclarationAnn]
modules)
                      (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
moduleName ModuleMap [(ModuleName, DeclarationRef)]
reexportRefs)) ModuleMap [IdeDeclarationAnn]
modules

resolveReexports'
  :: ModuleMap [IdeDeclarationAnn]
  -> [(P.ModuleName, P.DeclarationRef)]
  -> ReexportResult [IdeDeclarationAnn]
resolveReexports' :: ModuleMap [IdeDeclarationAnn]
-> [(ModuleName, DeclarationRef)]
-> ReexportResult [IdeDeclarationAnn]
resolveReexports' ModuleMap [IdeDeclarationAnn]
modules [(ModuleName, DeclarationRef)]
refs =
  forall a. a -> [(ModuleName, DeclarationRef)] -> ReexportResult a
ReexportResult (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[IdeDeclarationAnn]]
resolvedRefs) [(ModuleName, DeclarationRef)]
failedRefs
  where
    ([(ModuleName, DeclarationRef)]
failedRefs, [[IdeDeclarationAnn]]
resolvedRefs) = forall a b. [Either a b] -> ([a], [b])
partitionEithers ((ModuleName, DeclarationRef)
-> Either (ModuleName, DeclarationRef) [IdeDeclarationAnn]
resolveRef' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ModuleName, DeclarationRef)]
refs)
    resolveRef' :: (ModuleName, DeclarationRef)
-> Either (ModuleName, DeclarationRef) [IdeDeclarationAnn]
resolveRef' x :: (ModuleName, DeclarationRef)
x@(ModuleName
mn, DeclarationRef
r) = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
mn ModuleMap [IdeDeclarationAnn]
modules of
      Maybe [IdeDeclarationAnn]
Nothing -> forall a b. a -> Either a b
Left (ModuleName, DeclarationRef)
x
      Just [IdeDeclarationAnn]
decls' ->
        let
          setExportedFrom :: ModuleName -> IdeDeclarationAnn -> IdeDeclarationAnn
setExportedFrom = forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' IdeDeclarationAnn Annotation
idaAnnotation forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Annotation (Maybe ModuleName)
annExportedFrom) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
        in
          forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ModuleName
mn,) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ModuleName -> IdeDeclarationAnn -> IdeDeclarationAnn
setExportedFrom ModuleName
mn)) ([IdeDeclarationAnn]
-> DeclarationRef -> Either DeclarationRef [IdeDeclarationAnn]
resolveRef [IdeDeclarationAnn]
decls' DeclarationRef
r)

resolveRef
  :: [IdeDeclarationAnn]
  -> P.DeclarationRef
  -> Either P.DeclarationRef [IdeDeclarationAnn]
resolveRef :: [IdeDeclarationAnn]
-> DeclarationRef -> Either DeclarationRef [IdeDeclarationAnn]
resolveRef [IdeDeclarationAnn]
decls DeclarationRef
ref = case DeclarationRef
ref of
  P.TypeRef SourceSpan
_ ProperName 'TypeName
tn Maybe [ProperName 'ConstructorName]
mdtors ->
    case (IdeDeclaration -> Bool) -> Maybe IdeDeclarationAnn
findRef (forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeType
_IdeDeclType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeType (ProperName 'TypeName)
ideTypeName) (forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
tn))
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (IdeDeclaration -> Bool) -> Maybe IdeDeclarationAnn
findRef (forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeTypeSynonym
_IdeDeclTypeSynonym forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeTypeSynonym (ProperName 'TypeName)
ideSynonymName) (forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
tn)) of
      Maybe IdeDeclarationAnn
Nothing ->
        forall a b. a -> Either a b
Left DeclarationRef
ref
      Just IdeDeclarationAnn
d -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ IdeDeclarationAnn
d forall a. a -> [a] -> [a]
: case Maybe [ProperName 'ConstructorName]
mdtors of
          Maybe [ProperName 'ConstructorName]
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
            ProperName 'TypeName -> [IdeDeclarationAnn]
findDtors ProperName 'TypeName
tn
          Just [ProperName 'ConstructorName]
dtors -> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ProperName 'ConstructorName -> Maybe IdeDeclarationAnn
lookupDtor [ProperName 'ConstructorName]
dtors
  P.ValueRef SourceSpan
_ Ident
i ->
    (IdeDeclaration -> Bool)
-> Either DeclarationRef [IdeDeclarationAnn]
findWrapped (forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeValue
_IdeDeclValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeValue Ident
ideValueIdent) (forall a. Eq a => a -> a -> Bool
== Ident
i))
  P.ValueOpRef SourceSpan
_ OpName 'ValueOpName
name ->
    (IdeDeclaration -> Bool)
-> Either DeclarationRef [IdeDeclarationAnn]
findWrapped (forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeValueOperator
_IdeDeclValueOperator forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeValueOperator (OpName 'ValueOpName)
ideValueOpName) (forall a. Eq a => a -> a -> Bool
== OpName 'ValueOpName
name))
  P.TypeOpRef SourceSpan
_ OpName 'TypeOpName
name ->
    (IdeDeclaration -> Bool)
-> Either DeclarationRef [IdeDeclarationAnn]
findWrapped (forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeTypeOperator
_IdeDeclTypeOperator forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeTypeOperator (OpName 'TypeOpName)
ideTypeOpName) (forall a. Eq a => a -> a -> Bool
== OpName 'TypeOpName
name))
  P.TypeClassRef SourceSpan
_ ProperName 'ClassName
name ->
    (IdeDeclaration -> Bool)
-> Either DeclarationRef [IdeDeclarationAnn]
findWrapped (forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeTypeClass
_IdeDeclTypeClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeTypeClass (ProperName 'ClassName)
ideTCName) (forall a. Eq a => a -> a -> Bool
== ProperName 'ClassName
name))
  DeclarationRef
_ ->
    forall a b. a -> Either a b
Left DeclarationRef
ref
  where
    findWrapped :: (IdeDeclaration -> Bool)
-> Either DeclarationRef [IdeDeclarationAnn]
findWrapped = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left DeclarationRef
ref) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdeDeclaration -> Bool) -> Maybe IdeDeclarationAnn
findRef
    findRef :: (IdeDeclaration -> Bool) -> Maybe IdeDeclarationAnn
findRef IdeDeclaration -> Bool
f = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (IdeDeclaration -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdeDeclarationAnn -> IdeDeclaration
discardAnn) [IdeDeclarationAnn]
decls

    lookupDtor :: ProperName 'ConstructorName -> Maybe IdeDeclarationAnn
lookupDtor ProperName 'ConstructorName
name =
      (IdeDeclaration -> Bool) -> Maybe IdeDeclarationAnn
findRef (forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeDataConstructor
_IdeDeclDataConstructor forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeDataConstructor (ProperName 'ConstructorName)
ideDtorName) (forall a. Eq a => a -> a -> Bool
== ProperName 'ConstructorName
name))

    findDtors :: ProperName 'TypeName -> [IdeDeclarationAnn]
findDtors ProperName 'TypeName
tn = forall a. (a -> Bool) -> [a] -> [a]
filter (forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf
                           (Lens' IdeDeclarationAnn IdeDeclaration
idaDeclaration
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversal' IdeDeclaration IdeDataConstructor
_IdeDeclDataConstructor
                            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeDataConstructor (ProperName 'TypeName)
ideDtorTypeName) (forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
tn)) [IdeDeclarationAnn]
decls