{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
module Language.Haskell.Names.Recursive
  ( resolve
  , annotate
  ) where

import Data.Foldable (traverse_)
import Data.Graph(stronglyConnComp, flattenSCC)
import Data.Data (Data)
import Control.Monad (forM, forM_, unless)

import qualified Data.Map as Map (insert)
import Control.Monad.State.Strict (State, execState, get, modify)
import Language.Haskell.Exts

import Language.Haskell.Names.Types
import Language.Haskell.Names.SyntaxUtils
import Language.Haskell.Names.ScopeUtils
import Language.Haskell.Names.ModuleSymbols
import Language.Haskell.Names.Exports
import Language.Haskell.Names.Imports
import Language.Haskell.Names.Open.Base
import Language.Haskell.Names.Annotated


-- | Takes a list of modules and an environment and updates the environment
-- with each of the given modules' exported symbols. The modules can appear
-- in any order and can be mutually recursive.
resolve :: (Data l, Eq l) => [Module l] -> Environment -> Environment
resolve :: forall l.
(Data l, Eq l) =>
[Module l] -> Environment -> Environment
resolve [Module l]
modules Environment
environment = Environment
updatedEnvironment where
  moduleSCCs :: [[Module l]]
moduleSCCs = [Module l] -> [[Module l]]
forall l. [Module l] -> [[Module l]]
groupModules [Module l]
modules
  updatedEnvironment :: Environment
updatedEnvironment = State Environment () -> Environment -> Environment
forall s a. State s a -> s -> s
execState (([Module l] -> State Environment ())
-> [[Module l]] -> State Environment ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ [Module l] -> State Environment ()
forall l. (Data l, Eq l) => [Module l] -> State Environment ()
findFixPoint [[Module l]]
moduleSCCs) Environment
environment

-- | Take a set of modules and return a list of sets, where each sets for
-- a strongly connected component in the import graph.
groupModules :: [Module l] -> [[Module l]]
groupModules :: forall l. [Module l] -> [[Module l]]
groupModules [Module l]
modules =
  (SCC (Module l) -> [Module l]) -> [SCC (Module l)] -> [[Module l]]
forall a b. (a -> b) -> [a] -> [b]
map SCC (Module l) -> [Module l]
forall vertex. SCC vertex -> [vertex]
flattenSCC ([(Module l, ModuleName (), [ModuleName ()])] -> [SCC (Module l)]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp ((Module l -> (Module l, ModuleName (), [ModuleName ()]))
-> [Module l] -> [(Module l, ModuleName (), [ModuleName ()])]
forall a b. (a -> b) -> [a] -> [b]
map Module l -> (Module l, ModuleName (), [ModuleName ()])
forall l. Module l -> (Module l, ModuleName (), [ModuleName ()])
moduleNode [Module l]
modules))

moduleNode :: Module l -> (Module l, ModuleName (), [ModuleName ()])
moduleNode :: forall l. Module l -> (Module l, ModuleName (), [ModuleName ()])
moduleNode Module l
modul =
  ( Module l
modul
  , ModuleName l -> ModuleName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn (Module l -> ModuleName l
forall l. Module l -> ModuleName l
getModuleName Module l
modul)
  , (ImportDecl l -> ModuleName ())
-> [ImportDecl l] -> [ModuleName ()]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName l -> ModuleName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn (ModuleName l -> ModuleName ())
-> (ImportDecl l -> ModuleName l) -> ImportDecl l -> ModuleName ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl l -> ModuleName l
forall l. ImportDecl l -> ModuleName l
importModule) (Module l -> [ImportDecl l]
forall l. Module l -> [ImportDecl l]
getImports Module l
modul)
  )

-- | Compute interfaces for a set of mutually recursive modules and
-- update the environment accordingly.
findFixPoint :: (Data l, Eq l) => [Module l] -> State Environment ()
findFixPoint :: forall l. (Data l, Eq l) => [Module l] -> State Environment ()
findFixPoint [Module l]
modules = [[Symbol]] -> State Environment ()
loop (Int -> [Symbol] -> [[Symbol]]
forall a. Int -> a -> [a]
replicate ([Module l] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Module l]
modules) []) where
  loop :: [[Symbol]] -> State Environment ()
loop [[Symbol]]
modulesSymbols = do
    [(Module l, [Symbol])]
-> ((Module l, [Symbol]) -> State Environment ())
-> State Environment ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Module l] -> [[Symbol]] -> [(Module l, [Symbol])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Module l]
modules [[Symbol]]
modulesSymbols) (\(Module l
modul, [Symbol]
symbols) -> do
      (Environment -> Environment) -> State Environment ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (ModuleName () -> [Symbol] -> Environment -> Environment
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ModuleName l -> ModuleName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn (Module l -> ModuleName l
forall l. Module l -> ModuleName l
getModuleName Module l
modul)) [Symbol]
symbols))
    Environment
environment <- StateT Environment Identity Environment
forall s (m :: * -> *). MonadState s m => m s
get
    [[Symbol]]
modulesSymbols' <- [Module l]
-> (Module l -> StateT Environment Identity [Symbol])
-> StateT Environment Identity [[Symbol]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Module l]
modules (\Module l
modul -> do
      let globalTable :: Table
globalTable = Table -> Module l -> Table
forall l. (Eq l, Data l) => Table -> Module l -> Table
moduleTable (Environment -> Module l -> Table
forall l. Environment -> Module l -> Table
importTable Environment
environment Module l
modul) Module l
modul
      [Symbol] -> StateT Environment Identity [Symbol]
forall a. a -> StateT Environment Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> Module l -> [Symbol]
forall l. (Data l, Eq l) => Table -> Module l -> [Symbol]
exportedSymbols Table
globalTable Module l
modul))
    Bool -> State Environment () -> State Environment ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Symbol]]
modulesSymbols [[Symbol]] -> [[Symbol]] -> Bool
forall a. Eq a => a -> a -> Bool
== [[Symbol]]
modulesSymbols') ([[Symbol]] -> State Environment ()
loop [[Symbol]]
modulesSymbols')

-- | Annotate a module with scoping information using the given environment.
-- All imports of the given module should be in the environment.
annotate :: (Data l, Eq l, SrcInfo l) => Environment -> Module l -> Module (Scoped l)
annotate :: forall l.
(Data l, Eq l, SrcInfo l) =>
Environment -> Module l -> Module (Scoped l)
annotate Environment
environment modul :: Module l
modul@(Module l
_ Maybe (ModuleHead l)
_ [ModulePragma l]
_ [ImportDecl l]
_ [Decl l]
_) =
  Scoped l
-> Maybe (ModuleHead (Scoped l))
-> [ModulePragma (Scoped l)]
-> [ImportDecl (Scoped l)]
-> [Decl (Scoped l)]
-> Module (Scoped l)
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Module Scoped l
l' Maybe (ModuleHead (Scoped l))
maybeModuleHead' [ModulePragma (Scoped l)]
modulePragmas' [ImportDecl (Scoped l)]
importDecls' [Decl (Scoped l)]
decls' where
    Module l
l Maybe (ModuleHead l)
maybeModuleHead [ModulePragma l]
modulePragmas [ImportDecl l]
importDecls [Decl l]
decls = Module l
modul
    l' :: Scoped l
l' = l -> Scoped l
forall l. l -> Scoped l
none l
l
    maybeModuleHead' :: Maybe (ModuleHead (Scoped l))
maybeModuleHead' = case Maybe (ModuleHead l)
maybeModuleHead of
      Maybe (ModuleHead l)
Nothing -> Maybe (ModuleHead (Scoped l))
forall a. Maybe a
Nothing
      Just (ModuleHead l
lh ModuleName l
moduleName Maybe (WarningText l)
maybeWarning Maybe (ExportSpecList l)
maybeExports) ->
        ModuleHead (Scoped l) -> Maybe (ModuleHead (Scoped l))
forall a. a -> Maybe a
Just (Scoped l
-> ModuleName (Scoped l)
-> Maybe (WarningText (Scoped l))
-> Maybe (ExportSpecList (Scoped l))
-> ModuleHead (Scoped l)
forall l.
l
-> ModuleName l
-> Maybe (WarningText l)
-> Maybe (ExportSpecList l)
-> ModuleHead l
ModuleHead Scoped l
lh' ModuleName (Scoped l)
moduleName' Maybe (WarningText (Scoped l))
maybeWarning' Maybe (ExportSpecList (Scoped l))
maybeExports') where
          lh' :: Scoped l
lh'= l -> Scoped l
forall l. l -> Scoped l
none l
lh
          moduleName' :: ModuleName (Scoped l)
moduleName' = ModuleName l -> ModuleName (Scoped l)
forall (a :: * -> *) l. Annotated a => a l -> a (Scoped l)
noScope ModuleName l
moduleName
          maybeWarning' :: Maybe (WarningText (Scoped l))
maybeWarning' = (WarningText l -> WarningText (Scoped l))
-> Maybe (WarningText l) -> Maybe (WarningText (Scoped l))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WarningText l -> WarningText (Scoped l)
forall (a :: * -> *) l. Annotated a => a l -> a (Scoped l)
noScope Maybe (WarningText l)
maybeWarning
          maybeExports' :: Maybe (ExportSpecList (Scoped l))
maybeExports' = (ExportSpecList l -> ExportSpecList (Scoped l))
-> Maybe (ExportSpecList l) -> Maybe (ExportSpecList (Scoped l))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Table -> ExportSpecList l -> ExportSpecList (Scoped l)
forall l. Table -> ExportSpecList l -> ExportSpecList (Scoped l)
annotateExportSpecList Table
globalTable) Maybe (ExportSpecList l)
maybeExports
    modulePragmas' :: [ModulePragma (Scoped l)]
modulePragmas' = (ModulePragma l -> ModulePragma (Scoped l))
-> [ModulePragma l] -> [ModulePragma (Scoped l)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModulePragma l -> ModulePragma (Scoped l)
forall (a :: * -> *) l. Annotated a => a l -> a (Scoped l)
noScope [ModulePragma l]
modulePragmas
    importDecls' :: [ImportDecl (Scoped l)]
importDecls' = ModuleName l
-> Environment -> [ImportDecl l] -> [ImportDecl (Scoped l)]
forall l.
ModuleName l
-> Environment -> [ImportDecl l] -> [ImportDecl (Scoped l)]
annotateImportDecls ModuleName l
moduleName Environment
environment [ImportDecl l]
importDecls
    decls' :: [Decl (Scoped l)]
decls' = (Decl l -> Decl (Scoped l)) -> [Decl l] -> [Decl (Scoped l)]
forall a b. (a -> b) -> [a] -> [b]
map (Scope -> Decl l -> Decl (Scoped l)
forall (a :: * -> *) l.
(Resolvable (a (Scoped l)), Functor a, Typeable l) =>
Scope -> a l -> a (Scoped l)
annotateDecl (ModuleName () -> Table -> Scope
initialScope (ModuleName l -> ModuleName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn ModuleName l
moduleName) Table
globalTable)) [Decl l]
decls
    globalTable :: Table
globalTable = Table -> Module l -> Table
forall l. (Eq l, Data l) => Table -> Module l -> Table
moduleTable (Environment -> Module l -> Table
forall l. Environment -> Module l -> Table
importTable Environment
environment Module l
modul) Module l
modul
    moduleName :: ModuleName l
moduleName = Module l -> ModuleName l
forall l. Module l -> ModuleName l
getModuleName Module l
modul
annotate Environment
_ Module l
_ = [Char] -> Module (Scoped l)
forall a. HasCallStack => [Char] -> a
error [Char]
"annotateModule: non-standard modules are not supported"