{-# OPTIONS -fno-warn-name-shadowing #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
module Language.Haskell.Names.Recursive
  ( computeInterfaces
  , getInterfaces
  , annotateModule
  ) where

import           Fay.Compiler.Prelude

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

import           Data.Data                            (Data)
import           Data.Foldable
import           Data.Graph                           (flattenSCC, stronglyConnComp)
import qualified Data.Set                             as Set
import           Language.Haskell.Exts


-- | Take a set of modules and return a list of sets, where each sets for
-- a strongly connected component in the import graph.
-- The boolean determines if imports using @SOURCE@ are taken into account.
groupModules :: forall l . [Module l] -> [[Module l]]
groupModules :: [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 ([SCC (Module l)] -> [[Module l]])
-> [SCC (Module l)] -> [[Module l]]
forall a b. (a -> b) -> a -> b
$ [(Module l, ModuleName (), [ModuleName ()])] -> [SCC (Module l)]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp ([(Module l, ModuleName (), [ModuleName ()])] -> [SCC (Module l)])
-> [(Module l, ModuleName (), [ModuleName ()])] -> [SCC (Module l)]
forall a b. (a -> b) -> a -> b
$ (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 ()])
mkNode [Module l]
modules
  where
    mkNode :: Module l -> (Module l, ModuleName (), [ModuleName ()])
    mkNode :: Module l -> (Module l, ModuleName (), [ModuleName ()])
mkNode Module l
m =
      ( Module l
m
      , ModuleName l -> ModuleName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn (ModuleName l -> ModuleName ()) -> ModuleName l -> ModuleName ()
forall a b. (a -> b) -> a -> b
$ Module l -> ModuleName l
forall l. Module l -> ModuleName l
getModuleName Module l
m
      , (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) ([ImportDecl l] -> [ModuleName ()])
-> [ImportDecl l] -> [ModuleName ()]
forall a b. (a -> b) -> a -> b
$ Module l -> [ImportDecl l]
forall l. Module l -> [ImportDecl l]
getImports Module l
m
      )

-- | Annotate a module with scoping information. This assumes that all
-- module dependencies have been resolved and cached — usually you need
-- to run 'computeInterfaces' first, unless you have one module in
-- isolation.
annotateModule
  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Eq l)
  => Language -- ^ base language
  -> [Extension] -- ^ global extensions (e.g. specified on the command line)
  -> Module l -- ^ input module
  -> m (Module (Scoped l)) -- ^ output (annotated) module
annotateModule :: Language -> [Extension] -> Module l -> m (Module (Scoped l))
annotateModule Language
lang [Extension]
exts mod :: Module l
mod@(Module l
lm Maybe (ModuleHead l)
mh [ModulePragma l]
os [ImportDecl l]
is [Decl l]
ds) = do
  let extSet :: ExtensionSet
extSet = Language -> [Extension] -> Module l -> ExtensionSet
forall l. Language -> [Extension] -> Module l -> ExtensionSet
moduleExtensions Language
lang [Extension]
exts Module l
mod
  ([ImportDecl (Scoped l)]
imp, Table
impTbl) <- ExtensionSet
-> [ImportDecl l] -> m ([ImportDecl (Scoped l)], Table)
forall (m :: * -> *) l.
(MonadModule m, ModuleInfo m ~ Symbols) =>
ExtensionSet
-> [ImportDecl l] -> m ([ImportDecl (Scoped l)], Table)
processImports ExtensionSet
extSet [ImportDecl l]
is
  let tbl :: Table
tbl = Table -> Module l -> Table
forall l. (Eq l, Data l) => Table -> Module l -> Table
moduleTable Table
impTbl Module l
mod
  (Maybe (ExportSpecList (Scoped l))
exp, Symbols
_syms) <- Table -> Module l -> m (Maybe (ExportSpecList (Scoped l)), Symbols)
forall (m :: * -> *) l.
(MonadModule m, ModuleInfo m ~ Symbols, Data l, Eq l) =>
Table -> Module l -> m (Maybe (ExportSpecList (Scoped l)), Symbols)
processExports Table
tbl Module l
mod

  let
    lm' :: Scoped l
lm' = l -> Scoped l
forall l. l -> Scoped l
none l
lm
    os' :: [ModulePragma (Scoped l)]
os' = (ModulePragma l -> ModulePragma (Scoped l))
-> [ModulePragma l] -> [ModulePragma (Scoped l)]
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]
os
    is' :: [ImportDecl (Scoped l)]
is' = [ImportDecl (Scoped l)]
imp
    ds' :: [Decl (Scoped l)]
ds' = Scope -> Decl l -> Decl (Scoped l)
forall (a :: * -> *) l.
(Resolvable (a (Scoped l)), Functor a, Typeable l) =>
Scope -> a l -> a (Scoped l)
annotate (Table -> Scope
initialScope Table
tbl) (Decl l -> Decl (Scoped l)) -> [Decl l] -> [Decl (Scoped l)]
forall a b. (a -> b) -> [a] -> [b]
`map` [Decl l]
ds

    mh' :: Maybe (ModuleHead (Scoped l))
mh' = ((ModuleHead l -> ModuleHead (Scoped l))
 -> Maybe (ModuleHead l) -> Maybe (ModuleHead (Scoped l)))
-> Maybe (ModuleHead l)
-> (ModuleHead l -> ModuleHead (Scoped l))
-> Maybe (ModuleHead (Scoped l))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleHead l -> ModuleHead (Scoped l))
-> Maybe (ModuleHead l) -> Maybe (ModuleHead (Scoped l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (ModuleHead l)
mh ((ModuleHead l -> ModuleHead (Scoped l))
 -> Maybe (ModuleHead (Scoped l)))
-> (ModuleHead l -> ModuleHead (Scoped l))
-> Maybe (ModuleHead (Scoped l))
forall a b. (a -> b) -> a -> b
$ \(ModuleHead l
lh ModuleName l
n Maybe (WarningText l)
mw Maybe (ExportSpecList l)
_me) ->
      let
        lh' :: Scoped l
lh' = l -> Scoped l
forall l. l -> Scoped l
none l
lh
        n' :: ModuleName (Scoped l)
n'  = ModuleName l -> ModuleName (Scoped l)
forall (a :: * -> *) l. Annotated a => a l -> a (Scoped l)
noScope ModuleName l
n
        mw' :: Maybe (WarningText (Scoped l))
mw' = (WarningText l -> WarningText (Scoped l))
-> Maybe (WarningText l) -> Maybe (WarningText (Scoped l))
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)
mw
        me' :: Maybe (ExportSpecList (Scoped l))
me' = Maybe (ExportSpecList (Scoped l))
exp
      in 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)
n' Maybe (WarningText (Scoped l))
mw' Maybe (ExportSpecList (Scoped l))
me'

  Module (Scoped l) -> m (Module (Scoped l))
forall (m :: * -> *) a. Monad m => a -> m a
return (Module (Scoped l) -> m (Module (Scoped l)))
-> Module (Scoped l) -> m (Module (Scoped l))
forall a b. (a -> b) -> a -> b
$ 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
lm' Maybe (ModuleHead (Scoped l))
mh' [ModulePragma (Scoped l)]
os' [ImportDecl (Scoped l)]
is' [Decl (Scoped l)]
ds'

annotateModule Language
_ [Extension]
_ Module l
_ = [Char] -> m (Module (Scoped l))
forall a. HasCallStack => [Char] -> a
error [Char]
"annotateModule: non-standard modules are not supported"

-- | Compute interfaces for a set of mutually recursive modules and write
-- the results to the cache. Return the set of import/export errors.
findFixPoint
  :: (Ord l, Data l, MonadModule m, ModuleInfo m ~ Symbols)
  => [(Module l, ExtensionSet)]
      -- ^ module and all extensions with which it is to be compiled.
      -- Use 'moduleExtensions' to build this list.
  -> m (Set.Set (Error l))
findFixPoint :: [(Module l, ExtensionSet)] -> m (Set (Error l))
findFixPoint [(Module l, ExtensionSet)]
mods = [(Module l, ExtensionSet)] -> [Symbols] -> m (Set (Error l))
forall (m :: * -> *) l.
(MonadModule m, Data l, Ord l, ModuleInfo m ~ Symbols) =>
[(Module l, ExtensionSet)] -> [Symbols] -> m (Set (Error l))
go [(Module l, ExtensionSet)]
mods (((Module l, ExtensionSet) -> Symbols)
-> [(Module l, ExtensionSet)] -> [Symbols]
forall a b. (a -> b) -> [a] -> [b]
map (Symbols -> (Module l, ExtensionSet) -> Symbols
forall a b. a -> b -> a
const Symbols
forall a. Monoid a => a
mempty) [(Module l, ExtensionSet)]
mods) where
  go :: [(Module l, ExtensionSet)] -> [Symbols] -> m (Set (Error l))
go [(Module l, ExtensionSet)]
mods [Symbols]
syms = do
    [(Symbols, (Module l, ExtensionSet))]
-> ((Symbols, (Module l, ExtensionSet)) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Symbols]
-> [(Module l, ExtensionSet)]
-> [(Symbols, (Module l, ExtensionSet))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Symbols]
syms [(Module l, ExtensionSet)]
mods) (((Symbols, (Module l, ExtensionSet)) -> m ()) -> m ())
-> ((Symbols, (Module l, ExtensionSet)) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Symbols
s,(Module l
m, ExtensionSet
_)) -> ModuleName l -> ModuleInfo m -> m ()
forall (m :: * -> *) n.
(MonadModule m, ModName n) =>
n -> ModuleInfo m -> m ()
insertInCache (Module l -> ModuleName l
forall l. Module l -> ModuleName l
getModuleName Module l
m) ModuleInfo m
Symbols
s
    ([Symbols]
syms', [Set (Error l)]
errors) <- ([(Symbols, Set (Error l))] -> ([Symbols], [Set (Error l)]))
-> m [(Symbols, Set (Error l))] -> m ([Symbols], [Set (Error l)])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(Symbols, Set (Error l))] -> ([Symbols], [Set (Error l)])
forall a b. [(a, b)] -> ([a], [b])
unzip (m [(Symbols, Set (Error l))] -> m ([Symbols], [Set (Error l)]))
-> m [(Symbols, Set (Error l))] -> m ([Symbols], [Set (Error l)])
forall a b. (a -> b) -> a -> b
$ [(Module l, ExtensionSet)]
-> ((Module l, ExtensionSet) -> m (Symbols, Set (Error l)))
-> m [(Symbols, Set (Error l))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Module l, ExtensionSet)]
mods (((Module l, ExtensionSet) -> m (Symbols, Set (Error l)))
 -> m [(Symbols, Set (Error l))])
-> ((Module l, ExtensionSet) -> m (Symbols, Set (Error l)))
-> m [(Symbols, Set (Error l))]
forall a b. (a -> b) -> a -> b
$ \(Module l
m, ExtensionSet
extSet) -> do
      ([ImportDecl (Scoped l)]
imp, Table
impTbl) <- ExtensionSet
-> [ImportDecl l] -> m ([ImportDecl (Scoped l)], Table)
forall (m :: * -> *) l.
(MonadModule m, ModuleInfo m ~ Symbols) =>
ExtensionSet
-> [ImportDecl l] -> m ([ImportDecl (Scoped l)], Table)
processImports ExtensionSet
extSet ([ImportDecl l] -> m ([ImportDecl (Scoped l)], Table))
-> [ImportDecl l] -> m ([ImportDecl (Scoped l)], Table)
forall a b. (a -> b) -> a -> b
$ Module l -> [ImportDecl l]
forall l. Module l -> [ImportDecl l]
getImports Module l
m
      let tbl :: Table
tbl = Table -> Module l -> Table
forall l. (Eq l, Data l) => Table -> Module l -> Table
moduleTable Table
impTbl Module l
m
      (Maybe (ExportSpecList (Scoped l))
exp, Symbols
syms) <- Table -> Module l -> m (Maybe (ExportSpecList (Scoped l)), Symbols)
forall (m :: * -> *) l.
(MonadModule m, ModuleInfo m ~ Symbols, Data l, Eq l) =>
Table -> Module l -> m (Maybe (ExportSpecList (Scoped l)), Symbols)
processExports Table
tbl Module l
m
      (Symbols, Set (Error l)) -> m (Symbols, Set (Error l))
forall (m :: * -> *) a. Monad m => a -> m a
return (Symbols
syms, (ImportDecl (Scoped l) -> Set (Error l))
-> [ImportDecl (Scoped l)] -> Set (Error l)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ImportDecl (Scoped l) -> Set (Error l)
forall l (a :: * -> *).
(Ord l, Foldable a) =>
a (Scoped l) -> Set (Error l)
getErrors [ImportDecl (Scoped l)]
imp Set (Error l) -> Set (Error l) -> Set (Error l)
forall a. Semigroup a => a -> a -> a
<> (ExportSpecList (Scoped l) -> Set (Error l))
-> Maybe (ExportSpecList (Scoped l)) -> Set (Error l)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ExportSpecList (Scoped l) -> Set (Error l)
forall l (a :: * -> *).
(Ord l, Foldable a) =>
a (Scoped l) -> Set (Error l)
getErrors Maybe (ExportSpecList (Scoped l))
exp)
    if [Symbols]
syms' [Symbols] -> [Symbols] -> Bool
forall a. Eq a => a -> a -> Bool
== [Symbols]
syms
      then Set (Error l) -> m (Set (Error l))
forall (m :: * -> *) a. Monad m => a -> m a
return (Set (Error l) -> m (Set (Error l)))
-> Set (Error l) -> m (Set (Error l))
forall a b. (a -> b) -> a -> b
$ [Set (Error l)] -> Set (Error l)
forall a. Monoid a => [a] -> a
mconcat [Set (Error l)]
errors
      else [(Module l, ExtensionSet)] -> [Symbols] -> m (Set (Error l))
go [(Module l, ExtensionSet)]
mods [Symbols]
syms'

-- | 'computeInterfaces' takes a list of possibly recursive modules and
-- computes the interface of each module. The computed interfaces are
-- written into the @m@'s cache and are available to further computations
-- in this monad.
--
-- Returns the set of import/export errors. Note that the interfaces are
-- registered in the cache regardless of whether there are any errors, but
-- if there are errors, the interfaces may be incomplete.
computeInterfaces
  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)
  => Language -- ^ base language
  -> [Extension] -- ^ global extensions (e.g. specified on the command line)
  -> [Module l] -- ^ input modules
  -> m (Set.Set (Error l)) -- ^ errors in export or import lists
computeInterfaces :: Language -> [Extension] -> [Module l] -> m (Set (Error l))
computeInterfaces Language
lang [Extension]
exts =
  ([Set (Error l)] -> Set (Error l))
-> m [Set (Error l)] -> m (Set (Error l))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Set (Error l)] -> Set (Error l)
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (m [Set (Error l)] -> m (Set (Error l)))
-> ([Module l] -> m [Set (Error l)])
-> [Module l]
-> m (Set (Error l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Module l, ExtensionSet)] -> m (Set (Error l)))
-> [[(Module l, ExtensionSet)]] -> m [Set (Error l)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [(Module l, ExtensionSet)] -> m (Set (Error l))
forall l (m :: * -> *).
(Ord l, Data l, MonadModule m, ModuleInfo m ~ Symbols) =>
[(Module l, ExtensionSet)] -> m (Set (Error l))
findFixPoint ([[(Module l, ExtensionSet)]] -> m [Set (Error l)])
-> ([Module l] -> [[(Module l, ExtensionSet)]])
-> [Module l]
-> m [Set (Error l)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Module l] -> [(Module l, ExtensionSet)])
-> [[Module l]] -> [[(Module l, ExtensionSet)]]
forall a b. (a -> b) -> [a] -> [b]
map [Module l] -> [(Module l, ExtensionSet)]
supplyExtensions ([[Module l]] -> [[(Module l, ExtensionSet)]])
-> ([Module l] -> [[Module l]])
-> [Module l]
-> [[(Module l, ExtensionSet)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Module l] -> [[Module l]]
forall l. [Module l] -> [[Module l]]
groupModules
    where
    supplyExtensions :: [Module l] -> [(Module l, ExtensionSet)]
supplyExtensions = (Module l -> (Module l, ExtensionSet))
-> [Module l] -> [(Module l, ExtensionSet)]
forall a b. (a -> b) -> [a] -> [b]
map ((Module l -> (Module l, ExtensionSet))
 -> [Module l] -> [(Module l, ExtensionSet)])
-> (Module l -> (Module l, ExtensionSet))
-> [Module l]
-> [(Module l, ExtensionSet)]
forall a b. (a -> b) -> a -> b
$ \Module l
m -> (Module l
m, Language -> [Extension] -> Module l -> ExtensionSet
forall l. Language -> [Extension] -> Module l -> ExtensionSet
moduleExtensions Language
lang [Extension]
exts Module l
m)

-- | Like 'computeInterfaces', but also returns a list of interfaces, one
-- per module and in the same order
getInterfaces
  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)
  => Language -- ^ base language
  -> [Extension] -- ^ global extensions (e.g. specified on the command line)
  -> [Module l] -- ^ input modules
  -> m ([Symbols], Set.Set (Error l)) -- ^ output modules, and errors in export or import lists
getInterfaces :: Language
-> [Extension] -> [Module l] -> m ([Symbols], Set (Error l))
getInterfaces Language
lang [Extension]
exts [Module l]
mods = do
  Set (Error l)
errs <- Language -> [Extension] -> [Module l] -> m (Set (Error l))
forall (m :: * -> *) l.
(MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l,
 Ord l) =>
Language -> [Extension] -> [Module l] -> m (Set (Error l))
computeInterfaces Language
lang [Extension]
exts [Module l]
mods
  [Symbols]
ifaces <- [Module l] -> (Module l -> m Symbols) -> m [Symbols]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Module l]
mods ((Module l -> m Symbols) -> m [Symbols])
-> (Module l -> m Symbols) -> m [Symbols]
forall a b. (a -> b) -> a -> b
$ \Module l
mod ->
    let modName :: ModuleName l
modName = Module l -> ModuleName l
forall l. Module l -> ModuleName l
getModuleName Module l
mod in
    Symbols -> Maybe Symbols -> Symbols
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Symbols
forall a. HasCallStack => [Char] -> a
error ([Char] -> Symbols) -> [Char] -> Symbols
forall a b. (a -> b) -> a -> b
$ ModuleName l -> [Char]
forall n. ModName n => n -> [Char]
msg ModuleName l
modName) (Maybe Symbols -> Symbols) -> m (Maybe Symbols) -> m Symbols
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ModuleName l -> m (Maybe (ModuleInfo m))
forall (m :: * -> *) n.
(MonadModule m, ModName n) =>
n -> m (Maybe (ModuleInfo m))
lookupInCache ModuleName l
modName
  ([Symbols], Set (Error l)) -> m ([Symbols], Set (Error l))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbols]
ifaces, Set (Error l)
errs)
  where
    msg :: n -> [Char]
msg n
modName = [Char]
"getInterfaces: module " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ n -> [Char]
forall n. ModName n => n -> [Char]
modToString n
modName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not in the cache"