{- |
    Module      :  $Header$
    Description :  Check the export specification of a module
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                       2011 - 2016 Björn Peemöller
                       2015 - 2016 Yannik Potdevin
                       2016        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module implements a check and expansion of the export specification.
    Any errors in the specification are reported, and if there are no errors,
    the specification is expanded. The expansion does the following:
      * If there is no export specification, a specification exporting the
        entire module is generated.
      * Otherwise, (re)exports of modules are replaced by an export of all
        respective entities.
      * The export of a type with all constructors and fields is replaced
        by an enumeration of all constructors and fields.
      * The export of types without sub-entities is extended with an empty
        list of sub-entities.
-}
{-# LANGUAGE CPP #-}
module Checks.ExportCheck (exportCheck, expandExports) where

#if __GLASGOW_HASKELL__ >= 804
import Prelude hiding ((<>))
#endif

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative        ((<$>))
#endif
import           Control.Monad              (unless)
import qualified Control.Monad.State as S   (State, runState, gets, modify)
import           Data.List                  (nub, union)
import qualified Data.Map            as Map ( Map, elems, empty, insert
                                            , insertWith, lookup, toList )
import           Data.Maybe                 (fromMaybe)
import qualified Data.Set            as Set ( Set, empty, fromList, insert
                                            , member, toList )

import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.SpanInfo
import Curry.Base.Pretty
import Curry.Syntax

import Base.Messages       (Message, internalError, posMessage)
import Base.TopEnv         (allEntities, origName, localBindings, moduleImports)
import Base.Types          ( Type (..), unapplyType, arrowBase, PredType (..)
                           , DataConstr (..), constrIdent, recLabels
                           , ClassMethod, methodName
                           , TypeScheme (..) )
import Base.Utils          (findMultiples)

import Env.ModuleAlias     (AliasEnv)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTypeInfoUnique)
import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValueUnique)

currentModuleName :: String
currentModuleName :: String
currentModuleName = "Checks.ExportCheck"

-- ---------------------------------------------------------------------------
-- Check and expansion of the export statement
-- ---------------------------------------------------------------------------

expandExports :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
              -> Maybe ExportSpec -> ExportSpec
expandExports :: ModuleIdent
-> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> ExportSpec
expandExports m :: ModuleIdent
m aEnv :: AliasEnv
aEnv tcEnv :: TCEnv
tcEnv tyEnv :: ValueEnv
tyEnv spec :: Maybe ExportSpec
spec = SpanInfo -> [Export] -> ExportSpec
Exporting (Maybe ExportSpec -> SpanInfo
exportSpan Maybe ExportSpec
spec) [Export]
es
  where
  exportSpan :: Maybe ExportSpec -> SpanInfo
exportSpan (Just (Exporting spi :: SpanInfo
spi _)) = SpanInfo
spi
  exportSpan Nothing                  = SpanInfo
NoSpanInfo

  es :: [Export]
es = ModuleIdent
-> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Export]
expand ModuleIdent
m AliasEnv
aEnv TCEnv
tcEnv ValueEnv
tyEnv Maybe ExportSpec
spec

exportCheck :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv
            -> Maybe ExportSpec -> [Message]
exportCheck :: ModuleIdent
-> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Message]
exportCheck m :: ModuleIdent
m aEnv :: AliasEnv
aEnv tcEnv :: TCEnv
tcEnv tyEnv :: ValueEnv
tyEnv spec :: Maybe ExportSpec
spec = case ModuleIdent
-> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Message]
check ModuleIdent
m AliasEnv
aEnv TCEnv
tcEnv ValueEnv
tyEnv Maybe ExportSpec
spec of
  [] -> [Export] -> [Message]
checkNonUniqueness ([Export] -> [Message]) -> [Export] -> [Message]
forall a b. (a -> b) -> a -> b
$ ModuleIdent
-> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Export]
expand ModuleIdent
m AliasEnv
aEnv TCEnv
tcEnv ValueEnv
tyEnv Maybe ExportSpec
spec
  ms :: [Message]
ms -> [Message]
ms

-- -----------------------------------------------------------------------------
-- Export Check Monad
-- -----------------------------------------------------------------------------

data ECState = ECState
  { ECState -> ModuleIdent
moduleIdent  :: ModuleIdent
  , ECState -> Set ModuleIdent
importedMods :: Set.Set ModuleIdent
  , ECState -> TCEnv
tyConsEnv    :: TCEnv
  , ECState -> ValueEnv
valueEnv     :: ValueEnv
  , ECState -> [Message]
errors       :: [Message]
  }

type ECM a = S.State ECState a

runECM :: ECM a -> ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> (a, [Message])
runECM :: ECM a
-> ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> (a, [Message])
runECM ecm :: ECM a
ecm m :: ModuleIdent
m aEnv :: AliasEnv
aEnv tcEnv :: TCEnv
tcEnv tyEnv :: ValueEnv
tyEnv
  = let (a :: a
a, s' :: ECState
s') = ECM a -> ECState -> (a, ECState)
forall s a. State s a -> s -> (a, s)
S.runState ECM a
ecm ECState
initState in (a
a, [Message] -> [Message]
forall a. [a] -> [a]
reverse ([Message] -> [Message]) -> [Message] -> [Message]
forall a b. (a -> b) -> a -> b
$ ECState -> [Message]
errors ECState
s')
  where
  initState :: ECState
initState  = ModuleIdent
-> Set ModuleIdent -> TCEnv -> ValueEnv -> [Message] -> ECState
ECState ModuleIdent
m Set ModuleIdent
imported TCEnv
tcEnv ValueEnv
tyEnv []
  imported :: Set ModuleIdent
imported   = [ModuleIdent] -> Set ModuleIdent
forall a. Ord a => [a] -> Set a
Set.fromList (AliasEnv -> [ModuleIdent]
forall k a. Map k a -> [a]
Map.elems AliasEnv
aEnv)

getModuleIdent :: ECM ModuleIdent
getModuleIdent :: ECM ModuleIdent
getModuleIdent = (ECState -> ModuleIdent) -> ECM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ECState -> ModuleIdent
moduleIdent

getImportedModules :: ECM (Set.Set ModuleIdent)
getImportedModules :: ECM (Set ModuleIdent)
getImportedModules = (ECState -> Set ModuleIdent) -> ECM (Set ModuleIdent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ECState -> Set ModuleIdent
importedMods

getTyConsEnv :: ECM TCEnv
getTyConsEnv :: ECM TCEnv
getTyConsEnv = (ECState -> TCEnv) -> ECM TCEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ECState -> TCEnv
tyConsEnv

getValueEnv :: ECM ValueEnv
getValueEnv :: ECM ValueEnv
getValueEnv = (ECState -> ValueEnv) -> ECM ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ECState -> ValueEnv
valueEnv

report :: Message -> ECM ()
report :: Message -> ECM ()
report err :: Message
err = (ECState -> ECState) -> ECM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify (\ s :: ECState
s -> ECState
s { errors :: [Message]
errors = Message
err Message -> [Message] -> [Message]
forall a. a -> [a] -> [a]
: ECState -> [Message]
errors ECState
s })

ok :: ECM ()
ok :: ECM ()
ok = () -> ECM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- -----------------------------------------------------------------------------
-- Check
-- -----------------------------------------------------------------------------

check :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec
      -> [Message]
check :: ModuleIdent
-> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Message]
check m :: ModuleIdent
m aEnv :: AliasEnv
aEnv tcEnv :: TCEnv
tcEnv tyEnv :: ValueEnv
tyEnv spec :: Maybe ExportSpec
spec = ((), [Message]) -> [Message]
forall a b. (a, b) -> b
snd (((), [Message]) -> [Message]) -> ((), [Message]) -> [Message]
forall a b. (a -> b) -> a -> b
$ ECM ()
-> ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> ((), [Message])
forall a.
ECM a
-> ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> (a, [Message])
runECM (Maybe ExportSpec -> ECM ()
checkSpec Maybe ExportSpec
spec) ModuleIdent
m AliasEnv
aEnv TCEnv
tcEnv ValueEnv
tyEnv

-- |Check export specification.
checkSpec :: Maybe ExportSpec -> ECM ()
checkSpec :: Maybe ExportSpec -> ECM ()
checkSpec (Just (Exporting _ es :: [Export]
es)) = (Export -> ECM ()) -> [Export] -> ECM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Export -> ECM ()
checkExport [Export]
es
checkSpec Nothing                 = ECM ()
ok

-- |Check single export.
checkExport :: Export -> ECM ()
checkExport :: Export -> ECM ()
checkExport (Export         _ x :: QualIdent
x    ) = QualIdent -> ECM ()
checkThing QualIdent
x
checkExport (ExportTypeWith _ tc :: QualIdent
tc cs :: [Ident]
cs) = QualIdent -> [Ident] -> ECM ()
checkTypeWith QualIdent
tc [Ident]
cs
checkExport (ExportTypeAll  _ tc :: QualIdent
tc   ) = QualIdent -> ECM ()
checkTypeAll QualIdent
tc
checkExport (ExportModule   _ em :: ModuleIdent
em   ) = ModuleIdent -> ECM ()
checkModule ModuleIdent
em

-- |Check export of type constructor / function
checkThing :: QualIdent -> ECM ()
checkThing :: QualIdent -> ECM ()
checkThing tc :: QualIdent
tc = do
  ModuleIdent
m     <- ECM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- ECM TCEnv
getTyConsEnv
  case ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique ModuleIdent
m QualIdent
tc TCEnv
tcEnv of
    []  -> QualIdent -> Maybe [Export] -> ECM ()
checkThing' QualIdent
tc Maybe [Export]
forall a. Maybe a
Nothing
    [t :: TypeInfo
t] -> QualIdent -> Maybe [Export] -> ECM ()
checkThing' QualIdent
tc ([Export] -> Maybe [Export]
forall a. a -> Maybe a
Just [SpanInfo -> QualIdent -> [Ident] -> Export
ExportTypeWith SpanInfo
NoSpanInfo (TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName TypeInfo
t) []])
    ts :: [TypeInfo]
ts  -> Message -> ECM ()
report (QualIdent -> [TypeInfo] -> Message
errAmbiguousType QualIdent
tc [TypeInfo]
ts)

-- |Expand export of data cons / function
checkThing' :: QualIdent -> Maybe [Export] -> ECM ()
checkThing' :: QualIdent -> Maybe [Export] -> ECM ()
checkThing' f :: QualIdent
f tcExport :: Maybe [Export]
tcExport = do
  ModuleIdent
m     <- ECM ModuleIdent
getModuleIdent
  ValueEnv
tyEnv <- ECM ValueEnv
getValueEnv
  case ModuleIdent -> QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValueUnique ModuleIdent
m QualIdent
f ValueEnv
tyEnv of
    []  -> (QualIdent -> Message) -> ECM ()
justTcOr QualIdent -> Message
errUndefinedName
    [v :: ValueInfo
v] -> case ValueInfo
v of
      Value _ _ _ _ -> ECM ()
ok
      Label   _ _ _ -> Message -> ECM ()
report (Message -> ECM ()) -> Message -> ECM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> QualIdent -> Message
errOutsideTypeLabel QualIdent
f (ValueInfo -> QualIdent
getTc ValueInfo
v)
      _             -> (QualIdent -> Message) -> ECM ()
justTcOr ((QualIdent -> Message) -> ECM ())
-> (QualIdent -> Message) -> ECM ()
forall a b. (a -> b) -> a -> b
$ (QualIdent -> QualIdent -> Message)
-> QualIdent -> QualIdent -> Message
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent -> QualIdent -> Message
errOutsideTypeConstructor (ValueInfo -> QualIdent
getTc ValueInfo
v)
    fs :: [ValueInfo]
fs  -> Message -> ECM ()
report (QualIdent -> [ValueInfo] -> Message
errAmbiguousName QualIdent
f [ValueInfo]
fs)
  where
  justTcOr :: (QualIdent -> Message) -> ECM ()
justTcOr errFun :: QualIdent -> Message
errFun = ECM () -> ([Export] -> ECM ()) -> Maybe [Export] -> ECM ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Message -> ECM ()
report (Message -> ECM ()) -> Message -> ECM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> Message
errFun QualIdent
f) (ECM () -> [Export] -> ECM ()
forall a b. a -> b -> a
const ECM ()
ok) Maybe [Export]
tcExport

  getTc :: ValueInfo -> QualIdent
getTc (DataConstructor  _ _ _ (ForAll _ (PredType _ ty :: Type
ty))) = Type -> QualIdent
getTc' Type
ty
  getTc (NewtypeConstructor _ _ (ForAll _ (PredType _ ty :: Type
ty))) = Type -> QualIdent
getTc' Type
ty
  getTc (Label _ _ (ForAll _ (PredType _ (TypeArrow tc' :: Type
tc' _)))) =
    let (TypeConstructor tc :: QualIdent
tc, _) = Bool -> Type -> (Type, [Type])
unapplyType Bool
False Type
tc' in QualIdent
tc
  getTc err :: ValueInfo
err = String -> QualIdent
forall a. String -> a
internalError (String -> QualIdent) -> String -> QualIdent
forall a b. (a -> b) -> a -> b
$ String
currentModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".checkThing'.getTc: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueInfo -> String
forall a. Show a => a -> String
show ValueInfo
err

  getTc' :: Type -> QualIdent
getTc' ty :: Type
ty = let (TypeConstructor tc :: QualIdent
tc) = Type -> Type
arrowBase Type
ty in QualIdent
tc

checkTypeWith :: QualIdent -> [Ident] -> ECM ()
checkTypeWith :: QualIdent -> [Ident] -> ECM ()
checkTypeWith tc :: QualIdent
tc xs :: [Ident]
xs = do
  ModuleIdent
m     <- ECM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- ECM TCEnv
getTyConsEnv
  case ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique ModuleIdent
m QualIdent
tc TCEnv
tcEnv of
    []                   -> Message -> ECM ()
report (QualIdent -> Message
errUndefinedTypeOrClass QualIdent
tc)
    [DataType _ _ cs :: [DataConstr]
cs]    ->
      (Ident -> ECM ()) -> [Ident] -> ECM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((QualIdent -> Ident -> Message) -> [Ident] -> Ident -> ECM ()
forall (t :: * -> *) t.
(Foldable t, Eq t) =>
(QualIdent -> t -> Message) -> t t -> t -> ECM ()
checkElement QualIdent -> Ident -> Message
errUndefinedElement ([DataConstr] -> [Ident]
visibleElems [DataConstr]
cs )) [Ident]
xs'
    [RenamingType _ _ c :: DataConstr
c] ->
      (Ident -> ECM ()) -> [Ident] -> ECM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((QualIdent -> Ident -> Message) -> [Ident] -> Ident -> ECM ()
forall (t :: * -> *) t.
(Foldable t, Eq t) =>
(QualIdent -> t -> Message) -> t t -> t -> ECM ()
checkElement QualIdent -> Ident -> Message
errUndefinedElement ([DataConstr] -> [Ident]
visibleElems [DataConstr
c])) [Ident]
xs'
    [TypeClass   _ _ ms :: [ClassMethod]
ms] ->
      (Ident -> ECM ()) -> [Ident] -> ECM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((QualIdent -> Ident -> Message) -> [Ident] -> Ident -> ECM ()
forall (t :: * -> *) t.
(Foldable t, Eq t) =>
(QualIdent -> t -> Message) -> t t -> t -> ECM ()
checkElement QualIdent -> Ident -> Message
errUndefinedMethod ([ClassMethod] -> [Ident]
visibleMethods [ClassMethod]
ms)) [Ident]
xs'
    [_]                  -> Message -> ECM ()
report (QualIdent -> Message
errNonDataTypeOrTypeClass QualIdent
tc)
    ts :: [TypeInfo]
ts                   -> Message -> ECM ()
report (QualIdent -> [TypeInfo] -> Message
errAmbiguousType QualIdent
tc [TypeInfo]
ts)
  where
  xs' :: [Ident]
xs' = [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub [Ident]
xs
  -- check if given identifier is constructor/label/method of type/class tc
  checkElement :: (QualIdent -> t -> Message) -> t t -> t -> ECM ()
checkElement err :: QualIdent -> t -> Message
err cs' :: t t
cs' c :: t
c = Bool -> ECM () -> ECM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (t
c t -> t t -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t t
cs') (ECM () -> ECM ()) -> ECM () -> ECM ()
forall a b. (a -> b) -> a -> b
$ Message -> ECM ()
report (Message -> ECM ()) -> Message -> ECM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> t -> Message
err QualIdent
tc t
c

-- |Check type constructor with all data constructors and record labels.
checkTypeAll :: QualIdent -> ECM ()
checkTypeAll :: QualIdent -> ECM ()
checkTypeAll tc :: QualIdent
tc = do
  ModuleIdent
m     <- ECM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- ECM TCEnv
getTyConsEnv
  case ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique ModuleIdent
m QualIdent
tc TCEnv
tcEnv of
    []                   -> Message -> ECM ()
report (QualIdent -> Message
errUndefinedTypeOrClass QualIdent
tc)
    [DataType     _ _ _] -> ECM ()
ok
    [RenamingType _ _ _] -> ECM ()
ok
    [TypeClass    _ _ _] -> ECM ()
ok
    [_]                  -> Message -> ECM ()
report (QualIdent -> Message
errNonDataTypeOrTypeClass QualIdent
tc)
    ts :: [TypeInfo]
ts                   -> Message -> ECM ()
report (QualIdent -> [TypeInfo] -> Message
errAmbiguousType QualIdent
tc [TypeInfo]
ts)

checkModule :: ModuleIdent -> ECM ()
checkModule :: ModuleIdent -> ECM ()
checkModule em :: ModuleIdent
em = do
  Bool
isLocal   <- (ModuleIdent
em ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
==)         (ModuleIdent -> Bool)
-> ECM ModuleIdent -> StateT ECState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ECM ModuleIdent
getModuleIdent
  Bool
isForeign <- (ModuleIdent -> Set ModuleIdent -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ModuleIdent
em) (Set ModuleIdent -> Bool)
-> ECM (Set ModuleIdent) -> StateT ECState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ECM (Set ModuleIdent)
getImportedModules
  Bool -> ECM () -> ECM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isLocal Bool -> Bool -> Bool
|| Bool
isForeign) (ECM () -> ECM ()) -> ECM () -> ECM ()
forall a b. (a -> b) -> a -> b
$ Message -> ECM ()
report (Message -> ECM ()) -> Message -> ECM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> Message
errModuleNotImported ModuleIdent
em

-- Check whether two entities of the same kind (type or constructor/function)
-- share the same unqualified name, which is not allowed since they could
-- not be uniquely resolved at their usage.
-- For instance, consider the following module
-- @
-- module M (Bool, Prelude.Bool) where
-- data Bool = False | True
-- @
-- If this export would be allowed, in a module @M1@ as follows
-- @
-- module M1 where
-- import M (Bool)
-- @
-- the type @Bool@ could not be resolved uniquely to its definition.
-- Naturally, the same applies for constructors or functions.
checkNonUniqueness :: [Export] -> [Message]
checkNonUniqueness :: [Export] -> [Message]
checkNonUniqueness es :: [Export]
es = ([Ident] -> Message) -> [[Ident]] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map [Ident] -> Message
errMultipleType ([Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
types )
                     [Message] -> [Message] -> [Message]
forall a. [a] -> [a] -> [a]
++ ([Ident] -> Message) -> [[Ident]] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map [Ident] -> Message
errMultipleName ([Ident] -> [[Ident]]
forall a. Eq a => [a] -> [[a]]
findMultiples [Ident]
values)
  where
  types :: [Ident]
types  = [ QualIdent -> Ident
unqualify QualIdent
tc | ExportTypeWith _ tc :: QualIdent
tc _  <- [Export]
es ]
  values :: [Ident]
values = [ Ident
c            | ExportTypeWith _ _  cs :: [Ident]
cs <- [Export]
es, Ident
c <- [Ident]
cs ]
        [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [ QualIdent -> Ident
unqualify QualIdent
f  | Export _ f :: QualIdent
f <- [Export]
es ]

-- -----------------------------------------------------------------------------
-- Expansion
-- -----------------------------------------------------------------------------

expand :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec
       -> [Export]
expand :: ModuleIdent
-> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> [Export]
expand m :: ModuleIdent
m aEnv :: AliasEnv
aEnv tcEnv :: TCEnv
tcEnv tyEnv :: ValueEnv
tyEnv spec :: Maybe ExportSpec
spec
  = ([Export], [Message]) -> [Export]
forall a b. (a, b) -> a
fst (([Export], [Message]) -> [Export])
-> ([Export], [Message]) -> [Export]
forall a b. (a -> b) -> a -> b
$ ECM [Export]
-> ModuleIdent
-> AliasEnv
-> TCEnv
-> ValueEnv
-> ([Export], [Message])
forall a.
ECM a
-> ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> (a, [Message])
runECM (([Export] -> [Export]
joinExports ([Export] -> [Export])
-> ([Export] -> [Export]) -> [Export] -> [Export]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCEnv -> [Export] -> [Export]
canonExports TCEnv
tcEnv) ([Export] -> [Export]) -> ECM [Export] -> ECM [Export]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ExportSpec -> ECM [Export]
expandSpec Maybe ExportSpec
spec)
                 ModuleIdent
m AliasEnv
aEnv TCEnv
tcEnv ValueEnv
tyEnv

-- While checking all export specifications, the compiler expands
-- specifications of the form @T(..)@ into @T(C_1,...,C_m,l_1,...,l_n)@,
-- where @C_1,...,C_m@ are the data constructors of type @T@ and @l_1,...,l_n@
-- its field labels, and replaces an export specification
-- @module M@ by specifications for all entities which are defined
-- in module @M@ and imported into the current module with their
-- unqualified name. In order to distinguish exported type constructors
-- from exported functions, the former are translated into the equivalent
-- form @T()@. Note that the export specification @x@ may
-- export a type constructor @x@ /and/ a global function
-- @x@ at the same time.
--
-- /Note:/ This frontend allows redeclaration and export of imported
-- identifiers.

-- |Expand export specification
expandSpec :: Maybe ExportSpec -> ECM [Export]
expandSpec :: Maybe ExportSpec -> ECM [Export]
expandSpec (Just (Exporting _ es :: [Export]
es)) = [[Export]] -> [Export]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Export]] -> [Export])
-> StateT ECState Identity [[Export]] -> ECM [Export]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Export -> ECM [Export])
-> [Export] -> StateT ECState Identity [[Export]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Export -> ECM [Export]
expandExport [Export]
es
expandSpec Nothing                 = ECM [Export]
expandLocalModule

-- |Expand single export
expandExport :: Export -> ECM [Export]
expandExport :: Export -> ECM [Export]
expandExport (Export             _ x :: QualIdent
x) = QualIdent -> ECM [Export]
expandThing QualIdent
x
expandExport (ExportTypeWith _ tc :: QualIdent
tc cs :: [Ident]
cs) = QualIdent -> [Ident] -> ECM [Export]
expandTypeWith QualIdent
tc [Ident]
cs
expandExport (ExportTypeAll     _ tc :: QualIdent
tc) = QualIdent -> ECM [Export]
expandTypeAll QualIdent
tc
expandExport (ExportModule      _ em :: ModuleIdent
em) = ModuleIdent -> ECM [Export]
expandModule ModuleIdent
em

-- |Expand export of type constructor / function
expandThing :: QualIdent -> ECM [Export]
expandThing :: QualIdent -> ECM [Export]
expandThing tc :: QualIdent
tc = do
  ModuleIdent
m     <- ECM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- ECM TCEnv
getTyConsEnv
  case ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique ModuleIdent
m QualIdent
tc TCEnv
tcEnv of
    []  -> QualIdent -> Maybe [Export] -> ECM [Export]
expandThing' QualIdent
tc Maybe [Export]
forall a. Maybe a
Nothing
    [t :: TypeInfo
t] -> QualIdent -> Maybe [Export] -> ECM [Export]
expandThing' QualIdent
tc
             ([Export] -> Maybe [Export]
forall a. a -> Maybe a
Just [SpanInfo -> QualIdent -> [Ident] -> Export
ExportTypeWith SpanInfo
NoSpanInfo (TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName TypeInfo
t QualIdent -> QualIdent -> QualIdent
forall a b. (HasPosition a, HasPosition b) => a -> b -> a
@> QualIdent
tc) []])
    err :: [TypeInfo]
err -> String -> ECM [Export]
forall a. String -> a
internalError (String -> ECM [Export]) -> String -> ECM [Export]
forall a b. (a -> b) -> a -> b
$ String
currentModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".expandThing: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TypeInfo] -> String
forall a. Show a => a -> String
show [TypeInfo]
err

-- |Expand export of data cons / function
expandThing' :: QualIdent -> Maybe [Export] -> ECM [Export]
expandThing' :: QualIdent -> Maybe [Export] -> ECM [Export]
expandThing' f :: QualIdent
f tcExport :: Maybe [Export]
tcExport = do
  ModuleIdent
m     <- ECM ModuleIdent
getModuleIdent
  ValueEnv
tyEnv <- ECM ValueEnv
getValueEnv
  case ModuleIdent -> QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValueUnique ModuleIdent
m QualIdent
f ValueEnv
tyEnv of
    [Value f' :: QualIdent
f' _ _ _]
      -> [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Export] -> ECM [Export]) -> [Export] -> ECM [Export]
forall a b. (a -> b) -> a -> b
$ SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo (QualIdent
f' QualIdent -> QualIdent -> QualIdent
forall a b. (HasPosition a, HasPosition b) => a -> b -> a
@> QualIdent
f) Export -> [Export] -> [Export]
forall a. a -> [a] -> [a]
: [Export] -> Maybe [Export] -> [Export]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Export]
tcExport
    _
      -> [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Export] -> ECM [Export]) -> [Export] -> ECM [Export]
forall a b. (a -> b) -> a -> b
$ [Export] -> Maybe [Export] -> [Export]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Export]
tcExport

-- |Expand type constructor with explicit data constructors and record labels
expandTypeWith :: QualIdent -> [Ident] -> ECM [Export]
expandTypeWith :: QualIdent -> [Ident] -> ECM [Export]
expandTypeWith tc :: QualIdent
tc xs :: [Ident]
xs = do
  ModuleIdent
m     <- ECM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- ECM TCEnv
getTyConsEnv
  case ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique ModuleIdent
m QualIdent
tc TCEnv
tcEnv of
    [t :: TypeInfo
t] -> [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return [SpanInfo -> QualIdent -> [Ident] -> Export
ExportTypeWith SpanInfo
NoSpanInfo (TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName TypeInfo
t QualIdent -> QualIdent -> QualIdent
forall a b. (HasPosition a, HasPosition b) => a -> b -> a
@> QualIdent
tc) ([Ident] -> Export) -> [Ident] -> Export
forall a b. (a -> b) -> a -> b
$ [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub [Ident]
xs]
    err :: [TypeInfo]
err -> String -> ECM [Export]
forall a. String -> a
internalError (String -> ECM [Export]) -> String -> ECM [Export]
forall a b. (a -> b) -> a -> b
$ String
currentModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".expandTypeWith: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TypeInfo] -> String
forall a. Show a => a -> String
show [TypeInfo]
err

-- |Expand type constructor with all data constructors and record labels
expandTypeAll :: QualIdent -> ECM [Export]
expandTypeAll :: QualIdent -> ECM [Export]
expandTypeAll tc :: QualIdent
tc = do
  ModuleIdent
m     <- ECM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- ECM TCEnv
getTyConsEnv
  case ModuleIdent -> QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfoUnique ModuleIdent
m QualIdent
tc TCEnv
tcEnv of
    [t :: TypeInfo
t] -> [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeInfo -> Export
exportType TypeInfo
t]
    err :: [TypeInfo]
err -> String -> ECM [Export]
forall a. String -> a
internalError (String -> ECM [Export]) -> String -> ECM [Export]
forall a b. (a -> b) -> a -> b
$ String
currentModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".expandTypeAll: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [TypeInfo] -> String
forall a. Show a => a -> String
show [TypeInfo]
err

expandModule :: ModuleIdent -> ECM [Export]
expandModule :: ModuleIdent -> ECM [Export]
expandModule em :: ModuleIdent
em = do
  Bool
isLocal   <- (ModuleIdent
em ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
==)         (ModuleIdent -> Bool)
-> ECM ModuleIdent -> StateT ECState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ECM ModuleIdent
getModuleIdent
  Bool
isForeign <- (ModuleIdent -> Set ModuleIdent -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ModuleIdent
em) (Set ModuleIdent -> Bool)
-> ECM (Set ModuleIdent) -> StateT ECState Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ECM (Set ModuleIdent)
getImportedModules
  [Export]
locals    <- if Bool
isLocal   then ECM [Export]
expandLocalModule       else [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  [Export]
foreigns  <- if Bool
isForeign then ModuleIdent -> ECM [Export]
expandImportedModule ModuleIdent
em else [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Export] -> ECM [Export]) -> [Export] -> ECM [Export]
forall a b. (a -> b) -> a -> b
$ [Export]
locals [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [Export]
foreigns

expandLocalModule :: ECM [Export]
expandLocalModule :: ECM [Export]
expandLocalModule = do
  TCEnv
tcEnv <- ECM TCEnv
getTyConsEnv
  ValueEnv
tyEnv <- ECM ValueEnv
getValueEnv
  [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Export] -> ECM [Export]) -> [Export] -> ECM [Export]
forall a b. (a -> b) -> a -> b
$
       [ TypeInfo -> Export
exportType TypeInfo
t | (_, t :: TypeInfo
t) <- TCEnv -> [(Ident, TypeInfo)]
forall a. TopEnv a -> [(Ident, a)]
localBindings TCEnv
tcEnv ]
    [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [ SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo QualIdent
f'
         | (f :: Ident
f, Value f' :: QualIdent
f' _ _ _) <- ValueEnv -> [(Ident, ValueInfo)]
forall a. TopEnv a -> [(Ident, a)]
localBindings ValueEnv
tyEnv, Ident -> Bool
hasGlobalScope Ident
f ]
    [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [ SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo QualIdent
l'
         | (l :: Ident
l, Label l' :: QualIdent
l' _ _)   <- ValueEnv -> [(Ident, ValueInfo)]
forall a. TopEnv a -> [(Ident, a)]
localBindings ValueEnv
tyEnv, Ident -> Bool
hasGlobalScope Ident
l ]

-- |Expand a module export
expandImportedModule :: ModuleIdent -> ECM [Export]
expandImportedModule :: ModuleIdent -> ECM [Export]
expandImportedModule m :: ModuleIdent
m = do
  TCEnv
tcEnv <- ECM TCEnv
getTyConsEnv
  ValueEnv
tyEnv <- ECM ValueEnv
getValueEnv
  [Export] -> ECM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Export] -> ECM [Export]) -> [Export] -> ECM [Export]
forall a b. (a -> b) -> a -> b
$ [TypeInfo -> Export
exportType TypeInfo
t |       (_, t :: TypeInfo
t) <- ModuleIdent -> TCEnv -> [(Ident, TypeInfo)]
forall a. ModuleIdent -> TopEnv a -> [(Ident, a)]
moduleImports ModuleIdent
m TCEnv
tcEnv]
        [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo QualIdent
f | (_, Value f :: QualIdent
f _ _ _) <- ModuleIdent -> ValueEnv -> [(Ident, ValueInfo)]
forall a. ModuleIdent -> TopEnv a -> [(Ident, a)]
moduleImports ModuleIdent
m ValueEnv
tyEnv]
        [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo QualIdent
l | (_, Label l :: QualIdent
l _ _)   <- ModuleIdent -> ValueEnv -> [(Ident, ValueInfo)]
forall a. ModuleIdent -> TopEnv a -> [(Ident, a)]
moduleImports ModuleIdent
m ValueEnv
tyEnv]

exportType :: TypeInfo -> Export
exportType :: TypeInfo -> Export
exportType t :: TypeInfo
t = SpanInfo -> QualIdent -> [Ident] -> Export
ExportTypeWith SpanInfo
NoSpanInfo QualIdent
tc [Ident]
xs
  where tc :: QualIdent
tc = TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName TypeInfo
t
        xs :: [Ident]
xs = TypeInfo -> [Ident]
elements TypeInfo
t

-- -----------------------------------------------------------------------------
-- Canonicalization and joining of exports
-- -----------------------------------------------------------------------------

-- In contrast to Haskell, the export of field labels and record constructors
-- without their types is NOT allowed.
-- Thus, given the declaration @data T a = C { l :: a }@
-- the label @l@ and the constructor @C@ can only be exported together with the
-- type @T@, i.e., @(T(C,l))@.
-- Since record update operations are desugared to case expressions matching the
-- corresponding constructors of the record, the export of a label without its
-- type could result in a type error, when it is used for an update operation in
-- another module.

canonExports :: TCEnv -> [Export] -> [Export]
canonExports :: TCEnv -> [Export] -> [Export]
canonExports tcEnv :: TCEnv
tcEnv es :: [Export]
es = (Export -> Export) -> [Export] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (Map QualIdent Export -> Export -> Export
canonExport (TCEnv -> [Export] -> Map QualIdent Export
canonLabels TCEnv
tcEnv [Export]
es)) [Export]
es

canonExport :: Map.Map QualIdent Export -> Export -> Export
canonExport :: Map QualIdent Export -> Export -> Export
canonExport ls :: Map QualIdent Export
ls (Export spi :: SpanInfo
spi x :: QualIdent
x)             =
  Export -> Maybe Export -> Export
forall a. a -> Maybe a -> a
fromMaybe (SpanInfo -> QualIdent -> Export
Export SpanInfo
spi QualIdent
x) (QualIdent -> Map QualIdent Export -> Maybe Export
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup QualIdent
x Map QualIdent Export
ls)
canonExport _  (ExportTypeWith spi :: SpanInfo
spi tc :: QualIdent
tc xs :: [Ident]
xs) = SpanInfo -> QualIdent -> [Ident] -> Export
ExportTypeWith SpanInfo
spi QualIdent
tc [Ident]
xs
canonExport _  e :: Export
e                          = String -> Export
forall a. String -> a
internalError (String -> Export) -> String -> Export
forall a b. (a -> b) -> a -> b
$
  String
currentModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".canonExport: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Export -> String
forall a. Show a => a -> String
show Export
e

canonLabels :: TCEnv -> [Export] -> Map.Map QualIdent Export
canonLabels :: TCEnv -> [Export] -> Map QualIdent Export
canonLabels tcEnv :: TCEnv
tcEnv es :: [Export]
es = (TypeInfo -> Map QualIdent Export -> Map QualIdent Export)
-> Map QualIdent Export -> [TypeInfo] -> Map QualIdent Export
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TypeInfo -> Map QualIdent Export -> Map QualIdent Export
bindLabels Map QualIdent Export
forall k a. Map k a
Map.empty (TCEnv -> [TypeInfo]
forall a. TopEnv a -> [a]
allEntities TCEnv
tcEnv)
  where
  tcs :: [QualIdent]
tcs = [QualIdent
tc | ExportTypeWith _ tc :: QualIdent
tc _ <- [Export]
es]
  bindLabels :: TypeInfo -> Map QualIdent Export -> Map QualIdent Export
bindLabels t :: TypeInfo
t ls :: Map QualIdent Export
ls
    | QualIdent
tc' QualIdent -> [QualIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QualIdent]
tcs = (Ident -> Map QualIdent Export -> Map QualIdent Export)
-> Map QualIdent Export -> [Ident] -> Map QualIdent Export
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (QualIdent -> Ident -> Map QualIdent Export -> Map QualIdent Export
bindLabel QualIdent
tc') Map QualIdent Export
ls (TypeInfo -> [Ident]
elements TypeInfo
t)
    | Bool
otherwise     = Map QualIdent Export
ls
      where
        tc' :: QualIdent
tc'            = TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName TypeInfo
t
        bindLabel :: QualIdent -> Ident -> Map QualIdent Export -> Map QualIdent Export
bindLabel tc :: QualIdent
tc x :: Ident
x =
          QualIdent -> Export -> Map QualIdent Export -> Map QualIdent Export
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
tc Ident
x) (SpanInfo -> QualIdent -> [Ident] -> Export
ExportTypeWith SpanInfo
NoSpanInfo QualIdent
tc [Ident
x])

-- The expanded list of exported entities may contain duplicates. These
-- are removed by the function joinExports. In particular, this
-- function removes any field labels from the list of exported values
-- which are also exported along with their types.

joinExports :: [Export] -> [Export]
joinExports :: [Export] -> [Export]
joinExports es :: [Export]
es =  [SpanInfo -> QualIdent -> [Ident] -> Export
ExportTypeWith SpanInfo
NoSpanInfo QualIdent
tc [Ident]
cs | (tc :: QualIdent
tc, cs :: [Ident]
cs) <- [(QualIdent, [Ident])]
joinedTypes]
               [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo QualIdent
f             | QualIdent
f        <- [QualIdent]
joinedFuncs]
  where joinedTypes :: [(QualIdent, [Ident])]
joinedTypes = Map QualIdent [Ident] -> [(QualIdent, [Ident])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map QualIdent [Ident] -> [(QualIdent, [Ident])])
-> Map QualIdent [Ident] -> [(QualIdent, [Ident])]
forall a b. (a -> b) -> a -> b
$ (Export -> Map QualIdent [Ident] -> Map QualIdent [Ident])
-> Map QualIdent [Ident] -> [Export] -> Map QualIdent [Ident]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Export -> Map QualIdent [Ident] -> Map QualIdent [Ident]
joinType Map QualIdent [Ident]
forall k a. Map k a
Map.empty [Export]
es
        joinedFuncs :: [QualIdent]
joinedFuncs = Set QualIdent -> [QualIdent]
forall a. Set a -> [a]
Set.toList (Set QualIdent -> [QualIdent]) -> Set QualIdent -> [QualIdent]
forall a b. (a -> b) -> a -> b
$ (Export -> Set QualIdent -> Set QualIdent)
-> Set QualIdent -> [Export] -> Set QualIdent
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Export -> Set QualIdent -> Set QualIdent
joinFun  Set QualIdent
forall a. Set a
Set.empty [Export]
es

joinType :: Export -> Map.Map QualIdent [Ident] -> Map.Map QualIdent [Ident]
joinType :: Export -> Map QualIdent [Ident] -> Map QualIdent [Ident]
joinType (Export             _ _) tcs :: Map QualIdent [Ident]
tcs = Map QualIdent [Ident]
tcs
joinType (ExportTypeWith _ tc :: QualIdent
tc cs :: [Ident]
cs) tcs :: Map QualIdent [Ident]
tcs = ([Ident] -> [Ident] -> [Ident])
-> QualIdent
-> [Ident]
-> Map QualIdent [Ident]
-> Map QualIdent [Ident]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [Ident] -> [Ident] -> [Ident]
forall a. Eq a => [a] -> [a] -> [a]
union QualIdent
tc [Ident]
cs Map QualIdent [Ident]
tcs
joinType export :: Export
export                     _ = String -> Map QualIdent [Ident]
forall a. String -> a
internalError (String -> Map QualIdent [Ident])
-> String -> Map QualIdent [Ident]
forall a b. (a -> b) -> a -> b
$
  String
currentModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".joinType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Export -> String
forall a. Show a => a -> String
show Export
export

joinFun :: Export -> Set.Set QualIdent -> Set.Set QualIdent
joinFun :: Export -> Set QualIdent -> Set QualIdent
joinFun (Export           _ f :: QualIdent
f) fs :: Set QualIdent
fs = QualIdent
f QualIdent -> Set QualIdent -> Set QualIdent
forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set QualIdent
fs
joinFun (ExportTypeWith _ _ _) fs :: Set QualIdent
fs = Set QualIdent
fs
joinFun export :: Export
export                  _ = String -> Set QualIdent
forall a. String -> a
internalError (String -> Set QualIdent) -> String -> Set QualIdent
forall a b. (a -> b) -> a -> b
$
  String
currentModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".joinFun: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Export -> String
forall a. Show a => a -> String
show Export
export

-- ---------------------------------------------------------------------------
-- Auxiliary definitions
-- ---------------------------------------------------------------------------

elements :: TypeInfo -> [Ident]
elements :: TypeInfo -> [Ident]
elements (DataType      _ _ cs :: [DataConstr]
cs) = [DataConstr] -> [Ident]
visibleElems [DataConstr]
cs
elements (RenamingType   _ _ c :: DataConstr
c) = [DataConstr] -> [Ident]
visibleElems [DataConstr
c]
elements (AliasType    _ _ _ _) = []
elements (TypeClass     _ _ ms :: [ClassMethod]
ms) = [ClassMethod] -> [Ident]
visibleMethods [ClassMethod]
ms
elements (TypeVar            _) =
  String -> [Ident]
forall a. HasCallStack => String -> a
error "Checks.ExportCheck.elements: type variable"

-- get visible constructor and label identifiers for given constructor
visibleElems :: [DataConstr] -> [Ident]
visibleElems :: [DataConstr] -> [Ident]
visibleElems cs :: [DataConstr]
cs = (DataConstr -> Ident) -> [DataConstr] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map DataConstr -> Ident
constrIdent [DataConstr]
cs [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ ([Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ((DataConstr -> [Ident]) -> [DataConstr] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DataConstr -> [Ident]
recLabels [DataConstr]
cs))

-- get class method names
visibleMethods :: [ClassMethod] -> [Ident]
visibleMethods :: [ClassMethod] -> [Ident]
visibleMethods = (ClassMethod -> Ident) -> [ClassMethod] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map ClassMethod -> Ident
methodName

-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------

errAmbiguousName :: QualIdent -> [ValueInfo] -> Message
errAmbiguousName :: QualIdent -> [ValueInfo] -> Message
errAmbiguousName x :: QualIdent
x vs :: [ValueInfo]
vs = String -> QualIdent -> [QualIdent] -> Message
errAmbiguous "name" QualIdent
x ((ValueInfo -> QualIdent) -> [ValueInfo] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map ValueInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName [ValueInfo]
vs)

errAmbiguousType :: QualIdent -> [TypeInfo] -> Message
errAmbiguousType :: QualIdent -> [TypeInfo] -> Message
errAmbiguousType tc :: QualIdent
tc tcs :: [TypeInfo]
tcs = String -> QualIdent -> [QualIdent] -> Message
errAmbiguous "type" QualIdent
tc ((TypeInfo -> QualIdent) -> [TypeInfo] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> QualIdent
forall a. Entity a => a -> QualIdent
origName [TypeInfo]
tcs)

errAmbiguous :: String -> QualIdent -> [QualIdent] -> Message
errAmbiguous :: String -> QualIdent -> [QualIdent] -> Message
errAmbiguous what :: String
what qn :: QualIdent
qn qns :: [QualIdent]
qns = QualIdent -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage QualIdent
qn
  (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$   String -> Doc
text "Ambiguous" Doc -> Doc -> Doc
<+> String -> Doc
text String
what Doc -> Doc -> Doc
<+> String -> Doc
text (QualIdent -> String
escQualName QualIdent
qn)
  Doc -> Doc -> Doc
$+$ String -> Doc
text "It could refer to:"
  Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((QualIdent -> Doc) -> [QualIdent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (QualIdent -> String) -> QualIdent -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> String
escQualName) [QualIdent]
qns))

errModuleNotImported :: ModuleIdent -> Message
errModuleNotImported :: ModuleIdent -> Message
errModuleNotImported m :: ModuleIdent
m = ModuleIdent -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage ModuleIdent
m (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Module", ModuleIdent -> String
escModuleName ModuleIdent
m, "not imported"]

errMultipleName :: [Ident] -> Message
errMultipleName :: [Ident] -> Message
errMultipleName = String -> [Ident] -> Message
errMultiple "name"

errMultipleType :: [Ident] -> Message
errMultipleType :: [Ident] -> Message
errMultipleType = String -> [Ident] -> Message
errMultiple "type"

errMultiple :: String -> [Ident] -> Message
errMultiple :: String -> [Ident] -> Message
errMultiple _    []     = String -> Message
forall a. String -> a
internalError (String -> Message) -> String -> Message
forall a b. (a -> b) -> a -> b
$
  String
currentModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".errMultiple: empty list"
errMultiple what :: String
what (i :: Ident
i:is :: [Ident]
is) = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Ident
i (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
  String -> Doc
text "Multiple exports of" Doc -> Doc -> Doc
<+> String -> Doc
text String
what Doc -> Doc -> Doc
<+> String -> Doc
text (Ident -> String
escName Ident
i) Doc -> Doc -> Doc
<+> String -> Doc
text "at:"
  Doc -> Doc -> Doc
$+$ Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((Ident -> Doc) -> [Ident] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Doc
showPos (Ident
iIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
is)))
  where showPos :: Ident -> Doc
showPos = String -> Doc
text (String -> Doc) -> (Ident -> String) -> Ident -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> String
showLine (Position -> String) -> (Ident -> Position) -> Ident -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Position
forall a. HasPosition a => a -> Position
getPosition

errNonDataTypeOrTypeClass :: QualIdent -> Message
errNonDataTypeOrTypeClass :: QualIdent -> Message
errNonDataTypeOrTypeClass tc :: QualIdent
tc = QualIdent -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage QualIdent
tc (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [QualIdent -> String
escQualName QualIdent
tc, "is not a data type or type class"]

errOutsideTypeConstructor :: QualIdent -> QualIdent -> Message
errOutsideTypeConstructor :: QualIdent -> QualIdent -> Message
errOutsideTypeConstructor c :: QualIdent
c tc :: QualIdent
tc = String -> QualIdent -> QualIdent -> Message
errOutsideTypeExport "Data constructor" QualIdent
c QualIdent
tc

errOutsideTypeLabel :: QualIdent -> QualIdent -> Message
errOutsideTypeLabel :: QualIdent -> QualIdent -> Message
errOutsideTypeLabel l :: QualIdent
l tc :: QualIdent
tc = String -> QualIdent -> QualIdent -> Message
errOutsideTypeExport "Label" QualIdent
l QualIdent
tc

errOutsideTypeExport :: String -> QualIdent -> QualIdent -> Message
errOutsideTypeExport :: String -> QualIdent -> QualIdent -> Message
errOutsideTypeExport what :: String
what q :: QualIdent
q tc :: QualIdent
tc = QualIdent -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage QualIdent
q
  (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$   String -> Doc
text String
what Doc -> Doc -> Doc
<+> String -> Doc
text (QualIdent -> String
escQualName QualIdent
q)
         Doc -> Doc -> Doc
<+> String -> Doc
text "outside type export in export list"
  Doc -> Doc -> Doc
$+$ String -> Doc
text "Use `" Doc -> Doc -> Doc
<> String -> Doc
text (QualIdent -> String
qualName QualIdent
tc) Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text (QualIdent -> String
qualName QualIdent
q))
  Doc -> Doc -> Doc
<>  String -> Doc
text "' instead"

errUndefinedElement :: QualIdent -> Ident -> Message
errUndefinedElement :: QualIdent -> Ident -> Message
errUndefinedElement tc :: QualIdent
tc c :: Ident
c = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Ident
c (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ Ident -> String
escName Ident
c, "is not a constructor or label of type", QualIdent -> String
escQualName QualIdent
tc ]

errUndefinedMethod :: QualIdent -> Ident -> Message
errUndefinedMethod :: QualIdent -> Ident -> Message
errUndefinedMethod cls :: QualIdent
cls f :: Ident
f = Ident -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Ident
f (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  [ Ident -> String
escName Ident
f, "is not a method of class", QualIdent -> String
escQualName QualIdent
cls ]

errUndefinedName :: QualIdent -> Message
errUndefinedName :: QualIdent -> Message
errUndefinedName = String -> QualIdent -> Message
errUndefined "name"

errUndefinedTypeOrClass :: QualIdent -> Message
errUndefinedTypeOrClass :: QualIdent -> Message
errUndefinedTypeOrClass = String -> QualIdent -> Message
errUndefined "type or class"

errUndefined :: String -> QualIdent -> Message
errUndefined :: String -> QualIdent -> Message
errUndefined what :: String
what tc :: QualIdent
tc = QualIdent -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage QualIdent
tc (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text
  ["Undefined", String
what, QualIdent -> String
escQualName QualIdent
tc, "in export list"]