{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PatternGuards     #-}
{-# LANGUAGE TypeFamilies      #-}
{-# OPTIONS -fno-warn-name-shadowing #-}
{-# OPTIONS -fno-warn-orphans #-} -- ModName (ModuleName l)
module Language.Haskell.Names.Imports (processImports) where

import           Fay.Compiler.Prelude

import           Fay.Compiler.ModuleT
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import           Language.Haskell.Names.ScopeUtils
import           Language.Haskell.Names.SyntaxUtils
import           Language.Haskell.Names.Types

import           Control.Monad.Writer                     (WriterT (WriterT), runWriterT)
import           Data.Foldable                            (fold)
import           Data.Lens.Light
import qualified Data.Map                                 as Map
import qualified Data.Set                                 as Set
import           Language.Haskell.Exts

instance ModName (ModuleName l) where
  modToString :: ModuleName l -> String
modToString (ModuleName l
_ String
s) = String
s

preludeName :: String
preludeName :: String
preludeName = String
"Prelude"

processImports
  :: (MonadModule m, ModuleInfo m ~ Symbols)
  => ExtensionSet
  -> [ImportDecl l]
  -> m ([ImportDecl (Scoped l)], Global.Table)
processImports :: ExtensionSet
-> [ImportDecl l] -> m ([ImportDecl (Scoped l)], Table)
processImports ExtensionSet
exts [ImportDecl l]
importDecls = do

  ([ImportDecl (Scoped l)]
annotated, Table
tbl) <- WriterT Table m [ImportDecl (Scoped l)]
-> m ([ImportDecl (Scoped l)], Table)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Table m [ImportDecl (Scoped l)]
 -> m ([ImportDecl (Scoped l)], Table))
-> WriterT Table m [ImportDecl (Scoped l)]
-> m ([ImportDecl (Scoped l)], Table)
forall a b. (a -> b) -> a -> b
$ (ImportDecl l -> WriterT Table m (ImportDecl (Scoped l)))
-> [ImportDecl l] -> WriterT Table m [ImportDecl (Scoped l)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (m (ImportDecl (Scoped l), Table)
-> WriterT Table m (ImportDecl (Scoped l))
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (ImportDecl (Scoped l), Table)
 -> WriterT Table m (ImportDecl (Scoped l)))
-> (ImportDecl l -> m (ImportDecl (Scoped l), Table))
-> ImportDecl l
-> WriterT Table m (ImportDecl (Scoped l))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl l -> m (ImportDecl (Scoped l), Table)
forall (m :: * -> *) l.
(MonadModule m, ModuleInfo m ~ Symbols) =>
ImportDecl l -> m (ImportDecl (Scoped l), Table)
processImport) [ImportDecl l]
importDecls

  let
    isPreludeImported :: Bool
isPreludeImported = Bool -> Bool
not (Bool -> Bool) -> ([()] -> Bool) -> [()] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([()] -> Bool) -> [()] -> Bool
forall a b. (a -> b) -> a -> b
$
      [ () | ImportDecl { importModule :: forall l. ImportDecl l -> ModuleName l
importModule = ModuleName l
_ String
modName } <- [ImportDecl l]
importDecls
           , String
modName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
preludeName ]

    importPrelude :: Bool
importPrelude =
      KnownExtension
ImplicitPrelude KnownExtension -> ExtensionSet -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ExtensionSet
exts Bool -> Bool -> Bool
&&
      Bool -> Bool
not Bool
isPreludeImported

  Table
tbl' <-
    if Bool -> Bool
not Bool
importPrelude
      then Table -> m Table
forall (m :: * -> *) a. Monad m => a -> m a
return Table
tbl
      else do
        -- FIXME currently we don't have a way to signal an error when
        -- Prelude cannot be found
        Symbols
syms <- Maybe Symbols -> Symbols
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Maybe Symbols -> Symbols) -> m (Maybe Symbols) -> m Symbols
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> m (Maybe (ModuleInfo m))
forall (m :: * -> *) n.
(MonadModule m, ModName n) =>
n -> m (Maybe (ModuleInfo m))
getModuleInfo String
preludeName
        Table -> m Table
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> m Table) -> Table -> m Table
forall a b. (a -> b) -> a -> b
$ Table
tbl Table -> Table -> Table
forall a. Semigroup a => a -> a -> a
<>
          Bool -> ModuleName () -> Symbols -> Table
forall l. Bool -> ModuleName l -> Symbols -> Table
computeSymbolTable
            Bool
False -- not qualified
            (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
ModuleName () String
preludeName)
            Symbols
syms

  ([ImportDecl (Scoped l)], Table)
-> m ([ImportDecl (Scoped l)], Table)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ImportDecl (Scoped l)]
annotated, Table
tbl')

processImport
  :: (MonadModule m, ModuleInfo m ~ Symbols)
  => ImportDecl l
  -> m (ImportDecl (Scoped l), Global.Table)
processImport :: ImportDecl l -> m (ImportDecl (Scoped l), Table)
processImport ImportDecl l
imp = do
  Maybe Symbols
mbi <- ModuleName l -> m (Maybe (ModuleInfo m))
forall (m :: * -> *) n.
(MonadModule m, ModName n) =>
n -> m (Maybe (ModuleInfo m))
getModuleInfo (ImportDecl l -> ModuleName l
forall l. ImportDecl l -> ModuleName l
importModule ImportDecl l
imp)
  case Maybe Symbols
mbi of
    Maybe Symbols
Nothing ->
      let e :: Error l
e = ModuleName l -> Error l
forall l. ModuleName l -> Error l
EModNotFound (ImportDecl l -> ModuleName l
forall l. ImportDecl l -> ModuleName l
importModule ImportDecl l
imp)
      in (ImportDecl (Scoped l), Table) -> m (ImportDecl (Scoped l), Table)
forall (m :: * -> *) a. Monad m => a -> m a
return (Error l -> ImportDecl l -> ImportDecl (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError Error l
e ImportDecl l
imp, Table
Global.empty)
    Just Symbols
syms -> (ImportDecl (Scoped l), Table) -> m (ImportDecl (Scoped l), Table)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ImportDecl (Scoped l), Table)
 -> m (ImportDecl (Scoped l), Table))
-> (ImportDecl (Scoped l), Table)
-> m (ImportDecl (Scoped l), Table)
forall a b. (a -> b) -> a -> b
$ Symbols -> ImportDecl l -> (ImportDecl (Scoped l), Table)
forall l. Symbols -> ImportDecl l -> (ImportDecl (Scoped l), Table)
resolveImportDecl Symbols
syms ImportDecl l
imp

resolveImportDecl
  :: Symbols
  -> ImportDecl l
  -> (ImportDecl (Scoped l), Global.Table)
resolveImportDecl :: Symbols -> ImportDecl l -> (ImportDecl (Scoped l), Table)
resolveImportDecl Symbols
syms (ImportDecl l
l ModuleName l
mod Bool
qual Bool
src Bool
impSafe Maybe String
pkg Maybe (ModuleName l)
mbAs Maybe (ImportSpecList l)
mbSpecList) =
  let
    (Maybe (ImportSpecList (Scoped l))
mbSpecList', Symbols
impSyms) =
      (((ImportSpecList (Scoped l), Symbols) -> ImportSpecList (Scoped l))
-> Maybe (ImportSpecList (Scoped l), Symbols)
-> Maybe (ImportSpecList (Scoped l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ImportSpecList (Scoped l), Symbols) -> ImportSpecList (Scoped l)
forall a b. (a, b) -> a
fst (Maybe (ImportSpecList (Scoped l), Symbols)
 -> Maybe (ImportSpecList (Scoped l)))
-> (Maybe (ImportSpecList (Scoped l), Symbols) -> Symbols)
-> Maybe (ImportSpecList (Scoped l), Symbols)
-> (Maybe (ImportSpecList (Scoped l)), Symbols)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Symbols
-> ((ImportSpecList (Scoped l), Symbols) -> Symbols)
-> Maybe (ImportSpecList (Scoped l), Symbols)
-> Symbols
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Symbols
syms (ImportSpecList (Scoped l), Symbols) -> Symbols
forall a b. (a, b) -> b
snd) (Maybe (ImportSpecList (Scoped l), Symbols)
 -> (Maybe (ImportSpecList (Scoped l)), Symbols))
-> Maybe (ImportSpecList (Scoped l), Symbols)
-> (Maybe (ImportSpecList (Scoped l)), Symbols)
forall a b. (a -> b) -> a -> b
$
        ModuleName l
-> Symbols
-> ImportSpecList l
-> (ImportSpecList (Scoped l), Symbols)
forall l.
ModuleName l
-> Symbols
-> ImportSpecList l
-> (ImportSpecList (Scoped l), Symbols)
resolveImportSpecList ModuleName l
mod Symbols
syms (ImportSpecList l -> (ImportSpecList (Scoped l), Symbols))
-> Maybe (ImportSpecList l)
-> Maybe (ImportSpecList (Scoped l), Symbols)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ImportSpecList l)
mbSpecList
    tbl :: Table
tbl = Bool -> ModuleName l -> Symbols -> Table
forall l. Bool -> ModuleName l -> Symbols -> Table
computeSymbolTable Bool
qual (ModuleName l -> Maybe (ModuleName l) -> ModuleName l
forall a. a -> Maybe a -> a
fromMaybe ModuleName l
mod Maybe (ModuleName l)
mbAs) Symbols
impSyms
    info :: NameInfo l
info =
      case Maybe (ImportSpecList (Scoped l))
mbSpecList' of
        Just ImportSpecList (Scoped l)
sl | Scoped (ScopeError Error l
e) l
_ <- ImportSpecList (Scoped l) -> Scoped l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann ImportSpecList (Scoped l)
sl ->
          Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError Error l
e
        Maybe (ImportSpecList (Scoped l))
_ -> Table -> NameInfo l
forall l. Table -> NameInfo l
Import Table
tbl
  in
    (Scoped l
-> ModuleName (Scoped l)
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName (Scoped l))
-> Maybe (ImportSpecList (Scoped l))
-> ImportDecl (Scoped l)
forall l.
l
-> ModuleName l
-> Bool
-> Bool
-> Bool
-> Maybe String
-> Maybe (ModuleName l)
-> Maybe (ImportSpecList l)
-> ImportDecl l
ImportDecl
      (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
info l
l)
      (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbols -> NameInfo l
forall l. Symbols -> NameInfo l
ImportPart Symbols
syms) (l -> Scoped l) -> ModuleName l -> ModuleName (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleName l
mod)
      Bool
qual
      Bool
src
      Bool
impSafe
      Maybe String
pkg
      ((ModuleName l -> ModuleName (Scoped l))
-> Maybe (ModuleName l) -> Maybe (ModuleName (Scoped l))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ModuleName l -> ModuleName (Scoped l)
forall (a :: * -> *) l. Annotated a => a l -> a (Scoped l)
noScope Maybe (ModuleName l)
mbAs)
      Maybe (ImportSpecList (Scoped l))
mbSpecList'
    , Table
tbl)

resolveImportSpecList
  :: ModuleName l
  -> Symbols
  -> ImportSpecList l
  -> (ImportSpecList (Scoped l), Symbols)
resolveImportSpecList :: ModuleName l
-> Symbols
-> ImportSpecList l
-> (ImportSpecList (Scoped l), Symbols)
resolveImportSpecList ModuleName l
mod Symbols
allSyms (ImportSpecList l
l Bool
isHiding [ImportSpec l]
specs) =
  let specs' :: [ImportSpec (Scoped l)]
specs' = (ImportSpec l -> ImportSpec (Scoped l))
-> [ImportSpec l] -> [ImportSpec (Scoped l)]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName l
-> Bool -> Symbols -> ImportSpec l -> ImportSpec (Scoped l)
forall l.
ModuleName l
-> Bool -> Symbols -> ImportSpec l -> ImportSpec (Scoped l)
resolveImportSpec ModuleName l
mod Bool
isHiding Symbols
allSyms) [ImportSpec l]
specs
      mentionedSyms :: Symbols
mentionedSyms = [Symbols] -> Symbols
forall a. Monoid a => [a] -> a
mconcat ([Symbols] -> Symbols) -> [Symbols] -> Symbols
forall a b. (a -> b) -> a -> b
$ [Either (Error l) Symbols] -> [Symbols]
forall a b. [Either a b] -> [b]
rights ([Either (Error l) Symbols] -> [Symbols])
-> [Either (Error l) Symbols] -> [Symbols]
forall a b. (a -> b) -> a -> b
$ (ImportSpec (Scoped l) -> Either (Error l) Symbols)
-> [ImportSpec (Scoped l)] -> [Either (Error l) Symbols]
forall a b. (a -> b) -> [a] -> [b]
map ImportSpec (Scoped l) -> Either (Error l) Symbols
forall (a :: * -> *) l.
Annotated a =>
a (Scoped l) -> Either (Error l) Symbols
ann2syms [ImportSpec (Scoped l)]
specs'
      importedSyms :: Symbols
importedSyms = Bool -> Symbols -> Symbols -> Symbols
computeImportedSymbols Bool
isHiding Symbols
allSyms Symbols
mentionedSyms
      newAnn :: Scoped l
newAnn = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbols -> NameInfo l
forall l. Symbols -> NameInfo l
ImportPart Symbols
importedSyms) l
l
  in
    (Scoped l
-> Bool -> [ImportSpec (Scoped l)] -> ImportSpecList (Scoped l)
forall l. l -> Bool -> [ImportSpec l] -> ImportSpecList l
ImportSpecList Scoped l
newAnn Bool
isHiding [ImportSpec (Scoped l)]
specs', Symbols
importedSyms)

-- | This function takes care of the possible 'hiding' clause
computeImportedSymbols
  :: Bool
  -> Symbols -- ^ all symbols
  -> Symbols -- ^ mentioned symbols
  -> Symbols -- ^ imported symbols
computeImportedSymbols :: Bool -> Symbols -> Symbols -> Symbols
computeImportedSymbols Bool
isHiding (Symbols Set (SymValueInfo OrigName)
vs Set (SymTypeInfo OrigName)
ts) Symbols
mentionedSyms =
  case Bool
isHiding of
    Bool
False -> Symbols
mentionedSyms
    Bool
True ->
      let
        Symbols Set (SymValueInfo OrigName)
hvs Set (SymTypeInfo OrigName)
hts = Symbols
mentionedSyms
        allTys :: Map OrigName (SymTypeInfo OrigName)
allTys = (SymTypeInfo OrigName -> OrigName)
-> Set (SymTypeInfo OrigName)
-> Map OrigName (SymTypeInfo OrigName)
forall s a. Ord s => (a -> s) -> Set a -> Map s a
symbolMap SymTypeInfo OrigName -> OrigName
forall name. SymTypeInfo name -> name
st_origName Set (SymTypeInfo OrigName)
ts
        hidTys :: Map OrigName (SymTypeInfo OrigName)
hidTys = (SymTypeInfo OrigName -> OrigName)
-> Set (SymTypeInfo OrigName)
-> Map OrigName (SymTypeInfo OrigName)
forall s a. Ord s => (a -> s) -> Set a -> Map s a
symbolMap SymTypeInfo OrigName -> OrigName
forall name. SymTypeInfo name -> name
st_origName Set (SymTypeInfo OrigName)
hts
        allVls :: Map OrigName (SymValueInfo OrigName)
allVls = (SymValueInfo OrigName -> OrigName)
-> Set (SymValueInfo OrigName)
-> Map OrigName (SymValueInfo OrigName)
forall s a. Ord s => (a -> s) -> Set a -> Map s a
symbolMap SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName Set (SymValueInfo OrigName)
vs
        hidVls :: Map OrigName (SymValueInfo OrigName)
hidVls = (SymValueInfo OrigName -> OrigName)
-> Set (SymValueInfo OrigName)
-> Map OrigName (SymValueInfo OrigName)
forall s a. Ord s => (a -> s) -> Set a -> Map s a
symbolMap SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName Set (SymValueInfo OrigName)
hvs
      in
        Set (SymValueInfo OrigName)
-> Set (SymTypeInfo OrigName) -> Symbols
Symbols
          ([SymValueInfo OrigName] -> Set (SymValueInfo OrigName)
forall a. Ord a => [a] -> Set a
Set.fromList ([SymValueInfo OrigName] -> Set (SymValueInfo OrigName))
-> [SymValueInfo OrigName] -> Set (SymValueInfo OrigName)
forall a b. (a -> b) -> a -> b
$ Map OrigName (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall k a. Map k a -> [a]
Map.elems (Map OrigName (SymValueInfo OrigName) -> [SymValueInfo OrigName])
-> Map OrigName (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall a b. (a -> b) -> a -> b
$ Map OrigName (SymValueInfo OrigName)
allVls Map OrigName (SymValueInfo OrigName)
-> Map OrigName (SymValueInfo OrigName)
-> Map OrigName (SymValueInfo OrigName)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\ Map OrigName (SymValueInfo OrigName)
hidVls)
          ([SymTypeInfo OrigName] -> Set (SymTypeInfo OrigName)
forall a. Ord a => [a] -> Set a
Set.fromList ([SymTypeInfo OrigName] -> Set (SymTypeInfo OrigName))
-> [SymTypeInfo OrigName] -> Set (SymTypeInfo OrigName)
forall a b. (a -> b) -> a -> b
$ Map OrigName (SymTypeInfo OrigName) -> [SymTypeInfo OrigName]
forall k a. Map k a -> [a]
Map.elems (Map OrigName (SymTypeInfo OrigName) -> [SymTypeInfo OrigName])
-> Map OrigName (SymTypeInfo OrigName) -> [SymTypeInfo OrigName]
forall a b. (a -> b) -> a -> b
$ Map OrigName (SymTypeInfo OrigName)
allTys Map OrigName (SymTypeInfo OrigName)
-> Map OrigName (SymTypeInfo OrigName)
-> Map OrigName (SymTypeInfo OrigName)
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.\\ Map OrigName (SymTypeInfo OrigName)
hidTys)

symbolMap
  :: Ord s
  => (a -> s)
  -> Set.Set a
  -> Map.Map s a
symbolMap :: (a -> s) -> Set a -> Map s a
symbolMap a -> s
f Set a
is = [(s, a)] -> Map s a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(a -> s
f a
i, a
i) | a
i <- Set a -> [a]
forall a. Set a -> [a]
Set.toList Set a
is]

resolveImportSpec
  :: ModuleName l
  -> Bool
  -> Symbols
  -> ImportSpec l
  -> ImportSpec (Scoped l)
-- NB: this can be made more efficient
resolveImportSpec :: ModuleName l
-> Bool -> Symbols -> ImportSpec l -> ImportSpec (Scoped l)
resolveImportSpec ModuleName l
mod Bool
isHiding Symbols
syms ImportSpec l
spec =
  case ImportSpec l
spec of
    IVar l
_ Name l
n ->
      let
        matches :: Symbols
matches = [Symbols] -> Symbols
forall a. Monoid a => [a] -> a
mconcat ([Symbols] -> Symbols) -> [Symbols] -> Symbols
forall a b. (a -> b) -> a -> b
$
          -- Strictly speaking, the isConstructor check is unnecessary
          -- because constructors are lexically different from anything
          -- else.
          [ SymValueInfo OrigName -> Symbols
mkVal SymValueInfo OrigName
info
          | SymValueInfo OrigName
info <- [SymValueInfo OrigName]
vs
          , Bool -> Bool
not (SymValueInfo OrigName -> Bool
forall n. SymValueInfo n -> Bool
isConstructor SymValueInfo OrigName
info)
          , SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName SymValueInfo OrigName
info OrigName -> Name l -> Bool
forall l. OrigName -> Name l -> Bool
~~ Name l
n]
      in
        Error l -> Symbols -> ImportSpec l -> ImportSpec (Scoped l)
forall (f :: * -> *) l.
Functor f =>
Error l -> Symbols -> f l -> f (Scoped l)
checkUnique
          (Maybe (Name l) -> Name l -> ModuleName l -> Error l
forall l. Maybe (Name l) -> Name l -> ModuleName l -> Error l
ENotExported Maybe (Name l)
forall a. Maybe a
Nothing Name l
n ModuleName l
mod)
          Symbols
matches
          ImportSpec l
spec
    -- FIXME think about data families etc.
    IAbs l
_ Namespace l
_ Name l
n
      | Bool
isHiding ->
          -- This is a bit special. 'C' may match both types/classes and
          -- data constructors.
          -- FIXME Still check for uniqueness?
          let
            Symbols Set (SymValueInfo OrigName)
vlMatches Set (SymTypeInfo OrigName)
tyMatches =
              [Symbols] -> Symbols
forall a. Monoid a => [a] -> a
mconcat [ SymValueInfo OrigName -> Symbols
mkVal SymValueInfo OrigName
info | SymValueInfo OrigName
info <- [SymValueInfo OrigName]
vs, SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName SymValueInfo OrigName
info OrigName -> Name l -> Bool
forall l. OrigName -> Name l -> Bool
~~ Name l
n]
              Symbols -> Symbols -> Symbols
forall a. Semigroup a => a -> a -> a
<>
              [Symbols] -> Symbols
forall a. Monoid a => [a] -> a
mconcat [ SymTypeInfo OrigName -> Symbols
mkTy SymTypeInfo OrigName
info | SymTypeInfo OrigName
info <- [SymTypeInfo OrigName]
ts, SymTypeInfo OrigName -> OrigName
forall name. SymTypeInfo name -> name
st_origName SymTypeInfo OrigName
info OrigName -> Name l -> Bool
forall l. OrigName -> Name l -> Bool
~~ Name l
n]
          in
            if Set (SymTypeInfo OrigName) -> Bool
forall a. Set a -> Bool
Set.null Set (SymTypeInfo OrigName)
tyMatches Bool -> Bool -> Bool
&& Set (SymValueInfo OrigName) -> Bool
forall a. Set a -> Bool
Set.null Set (SymValueInfo OrigName)
vlMatches
              then
                Error l -> ImportSpec l -> ImportSpec (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (Maybe (Name l) -> Name l -> ModuleName l -> Error l
forall l. Maybe (Name l) -> Name l -> ModuleName l -> Error l
ENotExported Maybe (Name l)
forall a. Maybe a
Nothing Name l
n ModuleName l
mod) ImportSpec l
spec
              else
                NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbols -> NameInfo l
forall l. Symbols -> NameInfo l
ImportPart (Set (SymValueInfo OrigName)
-> Set (SymTypeInfo OrigName) -> Symbols
Symbols Set (SymValueInfo OrigName)
vlMatches Set (SymTypeInfo OrigName)
tyMatches)) (l -> Scoped l) -> ImportSpec l -> ImportSpec (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImportSpec l
spec
      | Bool
otherwise ->
          let
            matches :: Symbols
matches = [Symbols] -> Symbols
forall a. Monoid a => [a] -> a
mconcat
              [SymTypeInfo OrigName -> Symbols
mkTy SymTypeInfo OrigName
info | SymTypeInfo OrigName
info <- [SymTypeInfo OrigName]
ts, SymTypeInfo OrigName -> OrigName
forall name. SymTypeInfo name -> name
st_origName SymTypeInfo OrigName
info OrigName -> Name l -> Bool
forall l. OrigName -> Name l -> Bool
~~ Name l
n]
          in
            Error l -> Symbols -> ImportSpec l -> ImportSpec (Scoped l)
forall (f :: * -> *) l.
Functor f =>
Error l -> Symbols -> f l -> f (Scoped l)
checkUnique
              (Maybe (Name l) -> Name l -> ModuleName l -> Error l
forall l. Maybe (Name l) -> Name l -> ModuleName l -> Error l
ENotExported Maybe (Name l)
forall a. Maybe a
Nothing Name l
n ModuleName l
mod)
              Symbols
matches
              ImportSpec l
spec
    -- FIXME
    -- What about things like:
    -- head(..)
    -- String(..)
    -- ?
    IThingAll l
l Name l
n ->
      let
        matches :: [SymTypeInfo OrigName]
matches = [ SymTypeInfo OrigName
info | SymTypeInfo OrigName
info <- [SymTypeInfo OrigName]
ts, SymTypeInfo OrigName -> OrigName
forall name. SymTypeInfo name -> name
st_origName SymTypeInfo OrigName
info OrigName -> Name l -> Bool
forall l. OrigName -> Name l -> Bool
~~ Name l
n]
        subs :: Symbols
subs = [Symbols] -> Symbols
forall a. Monoid a => [a] -> a
mconcat
          [ SymValueInfo OrigName -> Symbols
mkVal SymValueInfo OrigName
info
          | SymTypeInfo OrigName
n <- [SymTypeInfo OrigName]
matches
          , SymValueInfo OrigName
info <- [SymValueInfo OrigName]
vs
          , Just OrigName
n' <- Maybe OrigName -> [Maybe OrigName]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OrigName -> [Maybe OrigName])
-> Maybe OrigName -> [Maybe OrigName]
forall a b. (a -> b) -> a -> b
$ SymValueInfo OrigName -> Maybe OrigName
forall n. SymValueInfo n -> Maybe n
sv_parent SymValueInfo OrigName
info
          , OrigName
n' OrigName -> OrigName -> Bool
forall a. Eq a => a -> a -> Bool
== SymTypeInfo OrigName -> OrigName
forall name. SymTypeInfo name -> name
st_origName SymTypeInfo OrigName
n ]
        n' :: Name (Scoped l)
n' =
          Error l -> Symbols -> Name l -> Name (Scoped l)
forall (f :: * -> *) l.
Functor f =>
Error l -> Symbols -> f l -> f (Scoped l)
checkUnique
            (Maybe (Name l) -> Name l -> ModuleName l -> Error l
forall l. Maybe (Name l) -> Name l -> ModuleName l -> Error l
ENotExported Maybe (Name l)
forall a. Maybe a
Nothing Name l
n ModuleName l
mod)
            ((SymTypeInfo OrigName -> Symbols)
-> [SymTypeInfo OrigName] -> Symbols
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SymTypeInfo OrigName -> Symbols
mkTy [SymTypeInfo OrigName]
matches)
            Name l
n
        in
          case Name (Scoped l) -> Scoped l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name (Scoped l)
n' of
            e :: Scoped l
e@(Scoped ScopeError{} l
_) -> Scoped l -> Name (Scoped l) -> ImportSpec (Scoped l)
forall l. l -> Name l -> ImportSpec l
IThingAll Scoped l
e Name (Scoped l)
n'
            Scoped l
_ ->
              Scoped l -> Name (Scoped l) -> ImportSpec (Scoped l)
forall l. l -> Name l -> ImportSpec l
IThingAll
                (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped
                  (Symbols -> NameInfo l
forall l. Symbols -> NameInfo l
ImportPart (Symbols
subs Symbols -> Symbols -> Symbols
forall a. Semigroup a => a -> a -> a
<> (SymTypeInfo OrigName -> Symbols)
-> [SymTypeInfo OrigName] -> Symbols
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SymTypeInfo OrigName -> Symbols
mkTy [SymTypeInfo OrigName]
matches))
                  l
l
                )
                Name (Scoped l)
n'

    IThingWith l
l Name l
n [CName l]
cns ->
      let
        matches :: [SymTypeInfo OrigName]
matches = [SymTypeInfo OrigName
info | SymTypeInfo OrigName
info <- [SymTypeInfo OrigName]
ts, SymTypeInfo OrigName -> OrigName
forall name. SymTypeInfo name -> name
st_origName SymTypeInfo OrigName
info OrigName -> Name l -> Bool
forall l. OrigName -> Name l -> Bool
~~ Name l
n]
        n' :: Name (Scoped l)
n' =
          Error l -> Symbols -> Name l -> Name (Scoped l)
forall (f :: * -> *) l.
Functor f =>
Error l -> Symbols -> f l -> f (Scoped l)
checkUnique
            (Maybe (Name l) -> Name l -> ModuleName l -> Error l
forall l. Maybe (Name l) -> Name l -> ModuleName l -> Error l
ENotExported Maybe (Name l)
forall a. Maybe a
Nothing Name l
n ModuleName l
mod)
            ((SymTypeInfo OrigName -> Symbols)
-> [SymTypeInfo OrigName] -> Symbols
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SymTypeInfo OrigName -> Symbols
mkTy [SymTypeInfo OrigName]
matches)
            Name l
n
        typeName :: OrigName
typeName = SymTypeInfo OrigName -> OrigName
forall name. SymTypeInfo name -> name
st_origName (SymTypeInfo OrigName -> OrigName)
-> SymTypeInfo OrigName -> OrigName
forall a b. (a -> b) -> a -> b
$ [SymTypeInfo OrigName] -> SymTypeInfo OrigName
forall a. [a] -> a
head [SymTypeInfo OrigName]
matches -- should be safe
        ([CName (Scoped l)]
cns', Symbols
cnSyms) =
          Symbols
-> OrigName
-> (CName l -> Error l)
-> [CName l]
-> ([CName (Scoped l)], Symbols)
forall l.
Symbols
-> OrigName
-> (CName l -> Error l)
-> [CName l]
-> ([CName (Scoped l)], Symbols)
resolveCNames
            Symbols
syms
            OrigName
typeName
            (\CName l
cn -> Maybe (Name l) -> Name l -> ModuleName l -> Error l
forall l. Maybe (Name l) -> Name l -> ModuleName l -> Error l
ENotExported (Name l -> Maybe (Name l)
forall a. a -> Maybe a
Just Name l
n) (CName l -> Name l
forall l. CName l -> Name l
unCName CName l
cn) ModuleName l
mod)
            [CName l]
cns
      in
        Scoped l
-> Name (Scoped l) -> [CName (Scoped l)] -> ImportSpec (Scoped l)
forall l. l -> Name l -> [CName l] -> ImportSpec l
IThingWith
          (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped
            (Symbols -> NameInfo l
forall l. Symbols -> NameInfo l
ImportPart (Symbols
cnSyms Symbols -> Symbols -> Symbols
forall a. Semigroup a => a -> a -> a
<> (SymTypeInfo OrigName -> Symbols)
-> [SymTypeInfo OrigName] -> Symbols
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SymTypeInfo OrigName -> Symbols
mkTy [SymTypeInfo OrigName]
matches))
            l
l
          )
          Name (Scoped l)
n'
          [CName (Scoped l)]
cns'
  where
    (~~) :: OrigName -> Name l -> Bool
    OrigName { origGName :: OrigName -> GName
origGName = GName { gName :: GName -> String
gName = String
n } } ~~ :: OrigName -> Name l -> Bool
~~ Name l
n' = String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name l -> String
forall l. Name l -> String
nameToString Name l
n'

    isConstructor :: SymValueInfo n -> Bool
    isConstructor :: SymValueInfo n -> Bool
isConstructor SymConstructor {} = Bool
True
    isConstructor SymValueInfo n
_ = Bool
False

    vs :: [SymValueInfo OrigName]
vs = Set (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall a. Set a -> [a]
Set.toList (Set (SymValueInfo OrigName) -> [SymValueInfo OrigName])
-> Set (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall a b. (a -> b) -> a -> b
$ Symbols
symsSymbols
-> Lens Symbols (Set (SymValueInfo OrigName))
-> Set (SymValueInfo OrigName)
forall b c. b -> Lens b c -> c
^.Lens Symbols (Set (SymValueInfo OrigName))
valSyms
    ts :: [SymTypeInfo OrigName]
ts = Set (SymTypeInfo OrigName) -> [SymTypeInfo OrigName]
forall a. Set a -> [a]
Set.toList (Set (SymTypeInfo OrigName) -> [SymTypeInfo OrigName])
-> Set (SymTypeInfo OrigName) -> [SymTypeInfo OrigName]
forall a b. (a -> b) -> a -> b
$ Symbols
symsSymbols
-> Lens Symbols (Set (SymTypeInfo OrigName))
-> Set (SymTypeInfo OrigName)
forall b c. b -> Lens b c -> c
^.Lens Symbols (Set (SymTypeInfo OrigName))
tySyms

ann2syms :: Annotated a => a (Scoped l) -> Either (Error l) (Symbols)
ann2syms :: a (Scoped l) -> Either (Error l) Symbols
ann2syms a (Scoped l)
a =
  case a (Scoped l) -> Scoped l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann a (Scoped l)
a of
    Scoped (ScopeError Error l
e) l
_ -> Error l -> Either (Error l) Symbols
forall a b. a -> Either a b
Left Error l
e
    Scoped (ImportPart Symbols
syms) l
_ -> Symbols -> Either (Error l) Symbols
forall a b. b -> Either a b
Right Symbols
syms
    Scoped l
_ -> Error l -> Either (Error l) Symbols
forall a b. a -> Either a b
Left (Error l -> Either (Error l) Symbols)
-> Error l -> Either (Error l) Symbols
forall a b. (a -> b) -> a -> b
$ String -> Error l
forall l. String -> Error l
EInternal String
"ann2syms"

checkUnique
  :: Functor f =>
  Error l ->
  Symbols ->
  f l ->
  f (Scoped l)
checkUnique :: Error l -> Symbols -> f l -> f (Scoped l)
checkUnique Error l
notFound syms :: Symbols
syms@(Symbols Set (SymValueInfo OrigName)
vs Set (SymTypeInfo OrigName)
ts) f l
f =
  case Set (SymValueInfo OrigName) -> Int
forall a. Set a -> Int
Set.size Set (SymValueInfo OrigName)
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set (SymTypeInfo OrigName) -> Int
forall a. Set a -> Int
Set.size Set (SymTypeInfo OrigName)
ts of
    Int
0 -> Error l -> f l -> f (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError Error l
notFound f l
f
    Int
1 -> NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Symbols -> NameInfo l
forall l. Symbols -> NameInfo l
ImportPart Symbols
syms) (l -> Scoped l) -> f l -> f (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f l
f
    -- there should be no clashes, and it should be checked elsewhere
    Int
_ -> Error l -> f l -> f (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (String -> Error l
forall l. String -> Error l
EInternal String
"ambiguous import") f l
f