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)
type ModuleGraph = [(ModuleName, [ModuleName])]
data ModuleSignature = ModuleSignature
{ ModuleSignature -> SourceSpan
sigSourceSpan :: SourceSpan
, ModuleSignature -> ModuleName
sigModuleName :: ModuleName
, ModuleSignature -> [(ModuleName, SourceSpan)]
sigImports :: [(ModuleName, SourceSpan)]
}
data DependencyDepth = Direct | Transitive
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)
usedModules :: Declaration -> Maybe (ModuleName, SourceSpan)
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
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))