{-# LANGUAGE TypeFamilies, NoMonoLocalBinds #-}
module Language.Haskell.Names.Exports
  ( exportedSymbols
  , annotateExportSpecList
  ) where

import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Monad
import Control.Monad.Writer
import Data.Data
import Language.Haskell.Exts
import Language.Haskell.Names.Types
import Language.Haskell.Names.ScopeUtils
import Language.Haskell.Names.SyntaxUtils
import Language.Haskell.Names.ModuleSymbols
import Language.Haskell.Names.GlobalSymbolTable as Global
import qualified Data.Set as Set (fromList, toList)


-- | Compute the list of symbols the given module exports using the given
-- table of symbols that are in scope in that module.
exportedSymbols :: (Data l, Eq l) => Global.Table -> Module l -> [Symbol]
exportedSymbols :: forall l. (Data l, Eq l) => Table -> Module l -> [Symbol]
exportedSymbols Table
globalTable Module l
modul = [Symbol] -> [Symbol]
nubSymbols (case Module l -> Maybe (ExportSpecList l)
forall l. Module l -> Maybe (ExportSpecList l)
getExportSpecList Module l
modul of
  Maybe (ExportSpecList l)
Nothing -> Table -> Module l -> [Symbol]
forall l. (Eq l, Data l) => Table -> Module l -> [Symbol]
moduleSymbols Table
globalTable Module l
modul
  Just (ExportSpecList l
_ [ExportSpec l]
exportSpecs) ->
    (ExportSpec l -> [Symbol]) -> [ExportSpec l] -> [Symbol]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Table -> ExportSpec l -> [Symbol]
forall l. Table -> ExportSpec l -> [Symbol]
exportSpecSymbols Table
globalTable) [ExportSpec l]
exportSpecs)

exportSpecSymbols :: Global.Table -> ExportSpec l -> [Symbol]
exportSpecSymbols :: forall l. Table -> ExportSpec l -> [Symbol]
exportSpecSymbols Table
globalTable ExportSpec l
exportSpec =
  case Table -> ExportSpec l -> ExportSpec (Scoped l)
forall l. Table -> ExportSpec l -> ExportSpec (Scoped l)
annotateExportSpec Table
globalTable ExportSpec l
exportSpec of
    EVar (Scoped (Export [Symbol]
symbols) l
_) QName (Scoped l)
_ -> [Symbol]
symbols
    EAbs (Scoped (Export [Symbol]
symbols) l
_) Namespace (Scoped l)
_ QName (Scoped l)
_ -> [Symbol]
symbols
    EThingWith (Scoped (Export [Symbol]
symbols) l
_) EWildcard (Scoped l)
_ QName (Scoped l)
_ [CName (Scoped l)]
_ -> [Symbol]
symbols
    EModuleContents (Scoped (Export [Symbol]
symbols) l
_) ModuleName (Scoped l)
_ -> [Symbol]
symbols
    ExportSpec (Scoped l)
_ -> []

-- | Annotate the given export list with scoping information using the given
-- table of symbols that are in scope in that module.
annotateExportSpecList :: Global.Table -> ExportSpecList l -> ExportSpecList (Scoped l)
annotateExportSpecList :: forall l. Table -> ExportSpecList l -> ExportSpecList (Scoped l)
annotateExportSpecList Table
globalTable (ExportSpecList l
l [ExportSpec l]
exportSpecs) =
  Scoped l -> [ExportSpec (Scoped l)] -> ExportSpecList (Scoped l)
forall l. l -> [ExportSpec l] -> ExportSpecList l
ExportSpecList (l -> Scoped l
forall l. l -> Scoped l
none l
l) ((ExportSpec l -> ExportSpec (Scoped l))
-> [ExportSpec l] -> [ExportSpec (Scoped l)]
forall a b. (a -> b) -> [a] -> [b]
map (Table -> ExportSpec l -> ExportSpec (Scoped l)
forall l. Table -> ExportSpec l -> ExportSpec (Scoped l)
annotateExportSpec Table
globalTable) [ExportSpec l]
exportSpecs)

annotateExportSpec :: Global.Table -> ExportSpec l -> ExportSpec (Scoped l)
annotateExportSpec :: forall l. Table -> ExportSpec l -> ExportSpec (Scoped l)
annotateExportSpec Table
globalTable ExportSpec l
exportSpec =
 case ExportSpec l
exportSpec of
  EVar l
l QName l
qn ->
    case QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupValue QName l
qn Table
globalTable of
      [] -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> Error l
forall l. QName l -> Error l
ENotInScope QName l
qn) ExportSpec l
exportSpec
      [Symbol
symbol] -> Scoped l -> QName (Scoped l) -> ExportSpec (Scoped l)
forall l. l -> QName l -> ExportSpec l
EVar (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([Symbol] -> NameInfo l
forall l. [Symbol] -> NameInfo l
Export [Symbol
symbol]) l
l)
            (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbol -> QName () -> NameInfo l
forall l. Symbol -> QName () -> NameInfo l
GlobalSymbol Symbol
symbol (QName l -> QName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn QName l
qn)) (l -> Scoped l) -> QName l -> QName (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName l
qn)
      [Symbol]
symbols -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> [Symbol] -> Error l
forall l. QName l -> [Symbol] -> Error l
EAmbiguous QName l
qn [Symbol]
symbols) ExportSpec l
exportSpec
  EAbs l
l ns :: Namespace l
ns@(PatternNamespace l
_) QName l
qn ->
    case QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupValue QName l
qn Table
globalTable of
      [] -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> Error l
forall l. QName l -> Error l
ENotInScope QName l
qn) ExportSpec l
exportSpec
      [Symbol
symbol] -> Scoped l
-> Namespace (Scoped l)
-> QName (Scoped l)
-> ExportSpec (Scoped l)
forall l. l -> Namespace l -> QName l -> ExportSpec l
EAbs (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([Symbol] -> NameInfo l
forall l. [Symbol] -> NameInfo l
Export [Symbol
symbol]) l
l)
            (Namespace l -> Namespace (Scoped l)
forall (a :: * -> *) l. Annotated a => a l -> a (Scoped l)
noScope Namespace l
ns)
            (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbol -> QName () -> NameInfo l
forall l. Symbol -> QName () -> NameInfo l
GlobalSymbol Symbol
symbol (QName l -> QName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn QName l
qn)) (l -> Scoped l) -> QName l -> QName (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName l
qn)
      [Symbol]
symbols -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> [Symbol] -> Error l
forall l. QName l -> [Symbol] -> Error l
EAmbiguous QName l
qn [Symbol]
symbols) ExportSpec l
exportSpec
  EAbs l
l Namespace l
ns QName l
qn ->
    case QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupType QName l
qn Table
globalTable of
      [] -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> Error l
forall l. QName l -> Error l
ENotInScope QName l
qn) ExportSpec l
exportSpec
      [Symbol
symbol] -> Scoped l
-> Namespace (Scoped l)
-> QName (Scoped l)
-> ExportSpec (Scoped l)
forall l. l -> Namespace l -> QName l -> ExportSpec l
EAbs (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([Symbol] -> NameInfo l
forall l. [Symbol] -> NameInfo l
Export [Symbol
symbol]) l
l)
            (Namespace l -> Namespace (Scoped l)
forall (a :: * -> *) l. Annotated a => a l -> a (Scoped l)
noScope Namespace l
ns)
            (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbol -> QName () -> NameInfo l
forall l. Symbol -> QName () -> NameInfo l
GlobalSymbol Symbol
symbol (QName l -> QName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn QName l
qn)) (l -> Scoped l) -> QName l -> QName (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName l
qn)
      [Symbol]
symbols -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> [Symbol] -> Error l
forall l. QName l -> [Symbol] -> Error l
EAmbiguous QName l
qn [Symbol]
symbols) ExportSpec l
exportSpec
  EThingWith l
l w :: EWildcard l
w@(EWildcard l
_ Int
_) QName l
qn [CName l]
_ ->
    case QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupType QName l
qn Table
globalTable of
      [] -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> Error l
forall l. QName l -> Error l
ENotInScope QName l
qn) ExportSpec l
exportSpec
      [Symbol
symbol] ->
        let
          subSymbols :: [Symbol]
subSymbols = [Symbol] -> [Symbol]
nubSymbols (do
              Symbol
subSymbol <- [[Symbol]] -> [Symbol]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Table -> [[Symbol]]
forall k a. Map k a -> [a]
Map.elems Table
globalTable)
              Just Name ()
subSymbolParentName <- Maybe (Name ()) -> [Maybe (Name ())]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Name ()) -> [Maybe (Name ())])
-> Maybe (Name ()) -> [Maybe (Name ())]
forall a b. (a -> b) -> a -> b
$ Symbol -> Maybe (Name ())
symbolParent Symbol
subSymbol
              Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Name ()
subSymbolParentName Name () -> Name () -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol -> Name ()
symbolName Symbol
symbol)
              Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Symbol -> ModuleName ()
symbolModule Symbol
subSymbol ModuleName () -> ModuleName () -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol -> ModuleName ()
symbolModule Symbol
symbol)
              Symbol -> [Symbol]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return Symbol
subSymbol)
          s :: [Symbol]
s = [Symbol
symbol] [Symbol] -> [Symbol] -> [Symbol]
forall a. Semigroup a => a -> a -> a
<> [Symbol]
subSymbols
        in
          Scoped l
-> EWildcard (Scoped l)
-> QName (Scoped l)
-> [CName (Scoped l)]
-> ExportSpec (Scoped l)
forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
EThingWith (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([Symbol] -> NameInfo l
forall l. [Symbol] -> NameInfo l
Export [Symbol]
s) l
l) ((l -> Scoped l) -> EWildcard l -> EWildcard (Scoped l)
forall a b. (a -> b) -> EWildcard a -> EWildcard b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
forall l. NameInfo l
None) EWildcard l
w) (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbol -> QName () -> NameInfo l
forall l. Symbol -> QName () -> NameInfo l
GlobalSymbol Symbol
symbol (QName l -> QName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn QName l
qn)) (l -> Scoped l) -> QName l -> QName (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName l
qn) []
      [Symbol]
symbols -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> [Symbol] -> Error l
forall l. QName l -> [Symbol] -> Error l
EAmbiguous QName l
qn [Symbol]
symbols) ExportSpec l
exportSpec
  EThingWith l
l w :: EWildcard l
w@(NoWildcard {}) QName l
qn [CName l]
cns ->
    case QName l -> Table -> [Symbol]
forall l. QName l -> Table -> [Symbol]
Global.lookupType QName l
qn Table
globalTable of
      [] -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> Error l
forall l. QName l -> Error l
ENotInScope QName l
qn) ExportSpec l
exportSpec
      [Symbol
symbol] ->
        let
          ([CName (Scoped l)]
cns', [Symbol]
subSymbols) =
            [Symbol]
-> Name ()
-> (CName l -> Error l)
-> [CName l]
-> ([CName (Scoped l)], [Symbol])
forall l.
[Symbol]
-> Name ()
-> (CName l -> Error l)
-> [CName l]
-> ([CName (Scoped l)], [Symbol])
resolveCNames
              ([[Symbol]] -> [Symbol]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Table -> [[Symbol]]
forall k a. Map k a -> [a]
Map.elems Table
globalTable))
              (Symbol -> Name ()
symbolName Symbol
symbol)
              (\CName l
cn -> QName l -> Error l
forall l. QName l -> Error l
ENotInScope (l -> Name l -> QName l
forall l. l -> Name l -> QName l
UnQual (CName l -> l
forall l. CName l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann CName l
cn) (CName l -> Name l
forall l. CName l -> Name l
unCName CName l
cn))) -- FIXME better error
              [CName l]
cns
          s :: [Symbol]
s = [Symbol
symbol] [Symbol] -> [Symbol] -> [Symbol]
forall a. Semigroup a => a -> a -> a
<> [Symbol]
subSymbols
        in
          Scoped l
-> EWildcard (Scoped l)
-> QName (Scoped l)
-> [CName (Scoped l)]
-> ExportSpec (Scoped l)
forall l. l -> EWildcard l -> QName l -> [CName l] -> ExportSpec l
EThingWith (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([Symbol] -> NameInfo l
forall l. [Symbol] -> NameInfo l
Export [Symbol]
s) l
l) ((l -> Scoped l) -> EWildcard l -> EWildcard (Scoped l)
forall a b. (a -> b) -> EWildcard a -> EWildcard b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
forall l. NameInfo l
None) EWildcard l
w) (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbol -> QName () -> NameInfo l
forall l. Symbol -> QName () -> NameInfo l
GlobalSymbol Symbol
symbol (QName l -> QName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn QName l
qn)) (l -> Scoped l) -> QName l -> QName (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName l
qn) [CName (Scoped l)]
cns'
      [Symbol]
symbols -> Error l -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (QName l -> [Symbol] -> Error l
forall l. QName l -> [Symbol] -> Error l
EAmbiguous QName l
qn [Symbol]
symbols) ExportSpec l
exportSpec
  -- FIXME ambiguity check
  EModuleContents l
_ ModuleName l
modulename -> NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped ([Symbol] -> NameInfo l
forall l. [Symbol] -> NameInfo l
Export [Symbol]
exportedSymbols) (l -> Scoped l) -> ExportSpec l -> ExportSpec (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExportSpec l
exportSpec where

      exportedSymbols :: [Symbol]
exportedSymbols = Set Symbol -> [Symbol]
forall a. Set a -> [a]
Set.toList (Set Symbol -> Set Symbol -> Set Symbol
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Symbol
inScopeQualified Set Symbol
inScopeUnqualified)

      inScopeQualified :: Set Symbol
inScopeQualified = [Symbol] -> Set Symbol
forall a. Ord a => [a] -> Set a
Set.fromList (do
          (Qual ()
_ ModuleName ()
prefix Name ()
_, [Symbol]
symbols) <- Table -> [(QName (), [Symbol])]
forall k a. Map k a -> [(k, a)]
Map.toList Table
globalTable
          Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ModuleName ()
prefix ModuleName () -> ModuleName () -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName l -> ModuleName ()
forall (a :: * -> *) l. Functor a => a l -> a ()
dropAnn ModuleName l
modulename)
          [Symbol]
symbols)

      inScopeUnqualified :: Set Symbol
inScopeUnqualified = [Symbol] -> Set Symbol
forall a. Ord a => [a] -> Set a
Set.fromList (do
          (UnQual ()
_ Name ()
_, [Symbol]
symbols) <- Table -> [(QName (), [Symbol])]
forall k a. Map k a -> [(k, a)]
Map.toList Table
globalTable
          [Symbol]
symbols)


nubSymbols :: [Symbol] -> [Symbol]
nubSymbols :: [Symbol] -> [Symbol]
nubSymbols = Set Symbol -> [Symbol] -> [Symbol]
forall {a}. Ord a => Set a -> [a] -> [a]
loop Set Symbol
forall a. Set a
Set.empty where
  loop :: Set a -> [a] -> [a]
loop Set a
_ [] = []
  loop Set a
a (a
b : [a]
c) = if a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member a
b Set a
a
    then Set a -> [a] -> [a]
loop Set a
a [a]
c
    else a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
loop (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
b Set a
a) [a]
c