-- | Provides the ability to sort modules based on module dependencies
module Language.PureScript.ModuleDependencies
  ( DependencyDepth(..)
  , sortModules
  , ModuleGraph
  , ModuleSignature(..)
  , moduleSignature
  ) where

import Protolude hiding (head)

import Data.Array ((!))
import Data.Graph (SCC(..), graphFromEdges, reachable, stronglyConnComp)
import Data.Set qualified as S
import Language.PureScript.AST (Declaration(..), ErrorMessageHint(..), Module(..), SourceSpan)
import Language.PureScript.Constants.Prim qualified as C
import Language.PureScript.Crash (internalError)
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, errorMessage', errorMessage'', parU)
import Language.PureScript.Names (ModuleName)

-- | A list of modules with their transitive dependencies
type ModuleGraph = [(ModuleName, [ModuleName])]

-- | A module signature for sorting dependencies.
data ModuleSignature = ModuleSignature
  { ModuleSignature -> SourceSpan
sigSourceSpan :: SourceSpan
  , ModuleSignature -> ModuleName
sigModuleName :: ModuleName
  , ModuleSignature -> [(ModuleName, SourceSpan)]
sigImports :: [(ModuleName, SourceSpan)]
  }

data DependencyDepth = Direct | Transitive

-- | Sort a collection of modules based on module dependencies.
--
-- Reports an error if the module graph contains a cycle.
sortModules
  :: forall m a
   . MonadError MultipleErrors m
  => DependencyDepth
  -> (a -> ModuleSignature)
  -> [a]
  -> m ([a], ModuleGraph)
sortModules :: forall (m :: * -> *) a.
MonadError MultipleErrors m =>
DependencyDepth
-> (a -> ModuleSignature) -> [a] -> m ([a], ModuleGraph)
sortModules DependencyDepth
dependencyDepth a -> ModuleSignature
toSig [a]
ms = do
    let
      ms' :: [(a, ModuleSignature)]
ms' = (\a
m -> (a
m, a -> ModuleSignature
toSig a
m)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
ms
      mns :: Set ModuleName
mns = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ModuleSignature -> ModuleName
sigModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, ModuleSignature)]
ms'
    [((a, ModuleSignature), ModuleName, [ModuleName])]
verts <- forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU [(a, ModuleSignature)]
ms' (Set ModuleName
-> (a, ModuleSignature)
-> m ((a, ModuleSignature), ModuleName, [ModuleName])
toGraphNode Set ModuleName
mns)
    [(a, ModuleSignature)]
ms'' <- forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU (forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [((a, ModuleSignature), ModuleName, [ModuleName])]
verts) forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SCC (a, ModuleSignature) -> m (a, ModuleSignature)
toModule
    let (Graph
graph, Vertex -> ((a, ModuleSignature), ModuleName, [ModuleName])
fromVertex, ModuleName -> Maybe Vertex
toVertex) = forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
graphFromEdges [((a, ModuleSignature), ModuleName, [ModuleName])]
verts
        moduleGraph :: ModuleGraph
moduleGraph = do ((a, ModuleSignature)
_, ModuleName
mn, [ModuleName]
_) <- [((a, ModuleSignature), ModuleName, [ModuleName])]
verts
                         let v :: Vertex
v       = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
internalError String
"sortModules: vertex not found") (ModuleName -> Maybe Vertex
toVertex ModuleName
mn)
                             deps :: [Vertex]
deps    = case DependencyDepth
dependencyDepth of
                                         DependencyDepth
Direct -> Graph
graph forall i e. Ix i => Array i e -> i -> e
! Vertex
v
                                         DependencyDepth
Transitive -> Graph -> Vertex -> [Vertex]
reachable Graph
graph Vertex
v
                             toKey :: Vertex -> ModuleName
toKey Vertex
i = case Vertex -> ((a, ModuleSignature), ModuleName, [ModuleName])
fromVertex Vertex
i of ((a, ModuleSignature)
_, ModuleName
key, [ModuleName]
_) -> ModuleName
key
                         forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
mn, forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= ModuleName
mn) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Vertex -> ModuleName
toKey [Vertex]
deps))
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, ModuleSignature)]
ms'', ModuleGraph
moduleGraph)
  where
    toGraphNode :: S.Set ModuleName -> (a, ModuleSignature) -> m ((a, ModuleSignature), ModuleName, [ModuleName])
    toGraphNode :: Set ModuleName
-> (a, ModuleSignature)
-> m ((a, ModuleSignature), ModuleName, [ModuleName])
toGraphNode Set ModuleName
mns m :: (a, ModuleSignature)
m@(a
_, ModuleSignature SourceSpan
_ ModuleName
mn [(ModuleName, SourceSpan)]
deps) = do
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU [(ModuleName, SourceSpan)]
deps forall a b. (a -> b) -> a -> b
$ \(ModuleName
dep, SourceSpan
pos) ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName
dep forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ModuleName]
C.primModules Bool -> Bool -> Bool
&& forall a. Ord a => a -> Set a -> Bool
S.notMember ModuleName
dep Set ModuleName
mns) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
mn)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
pos
            forall a b. (a -> b) -> a -> b
$ ModuleName -> SimpleErrorMessage
ModuleNotFound ModuleName
dep
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, ModuleSignature)
m, ModuleName
mn, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map forall a b. (a, b) -> a
fst [(ModuleName, SourceSpan)]
deps)

-- | Calculate a list of used modules based on explicit imports and qualified names.
usedModules :: Declaration -> Maybe (ModuleName, SourceSpan)
-- Regardless of whether an imported module is qualified we still need to
-- take into account its import to build an accurate list of dependencies.
usedModules :: Declaration -> Maybe (ModuleName, SourceSpan)
usedModules (ImportDeclaration (SourceSpan
ss, [Comment]
_) ModuleName
mn ImportDeclarationType
_ Maybe ModuleName
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleName
mn, SourceSpan
ss)
usedModules Declaration
_ = forall a. Maybe a
Nothing

-- | Convert a strongly connected component of the module graph to a module
toModule :: MonadError MultipleErrors m => SCC (a, ModuleSignature) -> m (a, ModuleSignature)
toModule :: forall (m :: * -> *) a.
MonadError MultipleErrors m =>
SCC (a, ModuleSignature) -> m (a, ModuleSignature)
toModule (AcyclicSCC (a, ModuleSignature)
m) = forall (m :: * -> *) a. Monad m => a -> m a
return (a, ModuleSignature)
m
toModule (CyclicSCC [(a, ModuleSignature)]
ms) =
  case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(a, ModuleSignature)]
ms of
    Maybe (NonEmpty (a, ModuleSignature))
Nothing ->
      forall a. HasCallStack => String -> a
internalError String
"toModule: empty CyclicSCC"
    Just NonEmpty (a, ModuleSignature)
ms' ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage'' (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleSignature -> SourceSpan
sigSourceSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) NonEmpty (a, ModuleSignature)
ms')
        forall a b. (a -> b) -> a -> b
$ NonEmpty ModuleName -> SimpleErrorMessage
CycleInModules (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ModuleSignature -> ModuleName
sigModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) NonEmpty (a, ModuleSignature)
ms')

moduleSignature :: Module -> ModuleSignature
moduleSignature :: Module -> ModuleSignature
moduleSignature (Module SourceSpan
ss [Comment]
_ ModuleName
mn [Declaration]
ds Maybe [DeclarationRef]
_) = SourceSpan
-> ModuleName -> [(ModuleName, SourceSpan)] -> ModuleSignature
ModuleSignature SourceSpan
ss ModuleName
mn (forall a. Ord a => [a] -> [a]
ordNub (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Declaration -> Maybe (ModuleName, SourceSpan)
usedModules [Declaration]
ds))