{-# 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 _ s :: String
s) = String
s

preludeName :: String
preludeName :: String
preludeName = "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 exts :: ExtensionSet
exts importDecls :: [ImportDecl l]
importDecls = do

  (annotated :: [ImportDecl (Scoped l)]
annotated, tbl :: 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 _ modName :: 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 imp :: 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
    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 syms :: 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 syms :: Symbols
syms (ImportDecl l :: l
l mod :: ModuleName l
mod qual :: Bool
qual src :: Bool
src impSafe :: Bool
impSafe pkg :: Maybe String
pkg mbAs :: Maybe (ModuleName l)
mbAs mbSpecList :: Maybe (ImportSpecList l)
mbSpecList) =
  let
    (mbSpecList' :: Maybe (ImportSpecList (Scoped l))
mbSpecList', impSyms :: 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 sl :: ImportSpecList (Scoped l)
sl | Scoped (ScopeError e :: Error l
e) _ <- 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
        _ -> 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 mod :: ModuleName l
mod allSyms :: Symbols
allSyms (ImportSpecList l :: l
l isHiding :: Bool
isHiding specs :: [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 isHiding :: Bool
isHiding (Symbols vs :: Set (SymValueInfo OrigName)
vs ts :: Set (SymTypeInfo OrigName)
ts) mentionedSyms :: Symbols
mentionedSyms =
  case Bool
isHiding of
    False -> Symbols
mentionedSyms
    True ->
      let
        Symbols hvs :: Set (SymValueInfo OrigName)
hvs hts :: 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 f :: a -> s
f is :: 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 mod :: ModuleName l
mod isHiding :: Bool
isHiding syms :: Symbols
syms spec :: ImportSpec l
spec =
  case ImportSpec l
spec of
    IVar _ n :: 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 _ _ n :: 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 vlMatches :: Set (SymValueInfo OrigName)
vlMatches tyMatches :: 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
l n :: 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 n' :: 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{} _) -> 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 -> 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
l n :: Name l
n cns :: [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
        (cns' :: [CName (Scoped l)]
cns', cnSyms :: 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
            (\cn :: 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
~~ n' :: 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 _ = 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 :: 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 e :: Error l
e) _ -> Error l -> Either (Error l) Symbols
forall a b. a -> Either a b
Left Error l
e
    Scoped (ImportPart syms :: Symbols
syms) _ -> Symbols -> Either (Error l) Symbols
forall a b. b -> Either a b
Right Symbols
syms
    _ -> 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 "ann2syms"

checkUnique
  :: Functor f =>
  Error l ->
  Symbols ->
  f l ->
  f (Scoped l)
checkUnique :: Error l -> Symbols -> f l -> f (Scoped l)
checkUnique notFound :: Error l
notFound syms :: Symbols
syms@(Symbols vs :: Set (SymValueInfo OrigName)
vs ts :: Set (SymTypeInfo OrigName)
ts) f :: 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
    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
    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
    _ -> 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 "ambiguous import") f l
f