{- |
Module : $Header$
Description : Importing interface declarations
Copyright : (c) 2000 - 2003 Wolfgang Lux
2011 Björn Peemöller
2016 Jan Tikovsky
2016 Finn Teegen
License : BSD-3-clause
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module provides the function 'importModules' to bring the imported
entities into the module's scope, and the function 'qualifyEnv' to
qualify the environment prior to computing the export interface.
-}
module Imports (importInterfaces, importModules, qualifyEnv) where
import Data.List (nubBy, find)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe, isJust)
import qualified Data.Set as Set
import Curry.Base.Ident
import Curry.Base.SpanInfo
import Curry.Base.Monad
import Curry.Syntax
import Base.CurryKinds (toKind')
import Base.CurryTypes ( toQualType, toQualTypes, toQualPredType, toConstrType
, toMethodType )
import Base.Kinds
import Base.Messages
import Base.TopEnv
import Base.Types
import Base.TypeSubst
import Env.Class
import Env.Instance
import Env.Interface
import Env.ModuleAlias (importAliases, initAliasEnv)
import Env.OpPrec
import Env.TypeConstructor
import Env.Value
import CompilerEnv
importModules :: Monad m => Module a -> InterfaceEnv -> [ImportDecl]
-> CYT m CompilerEnv
importModules mdl@(Module _ _ _ mid _ _ _) iEnv expImps
= ok $ foldl importModule initEnv expImps
where
initEnv = (initCompilerEnv mid)
{ aliasEnv = importAliases expImps -- import module aliases
, interfaceEnv = iEnv -- imported interfaces
, extensions = knownExtensions mdl
}
importModule env (ImportDecl _ m q asM is) =
case Map.lookup m iEnv of
Just intf -> importInterface (fromMaybe m asM) q is intf env
Nothing -> internalError $ "Imports.importModules: no interface for "
++ show m
-- |The function 'importInterfaces' brings the declarations of all
-- imported interfaces into scope for the current 'Interface'.
importInterfaces :: Interface -> InterfaceEnv -> CompilerEnv
importInterfaces (Interface m is _) iEnv
= importUnifyData $ foldl importModule initEnv is
where
initEnv = (initCompilerEnv m) { aliasEnv = initAliasEnv, interfaceEnv = iEnv }
importModule env (IImportDecl _ i) = case Map.lookup i iEnv of
Just intf -> importInterfaceIntf intf env
Nothing -> internalError $ "Imports.importInterfaces: no interface for "
++ show m
-- ---------------------------------------------------------------------------
-- Importing an interface into the module
-- ---------------------------------------------------------------------------
-- Four kinds of environments are computed from the interface:
--
-- 1. The operator precedences
-- 2. The type constructors
-- 3. The types of the data constructors and functions (values)
-- 4. The instances
--
-- Note that the original names of all entities defined in the imported module
-- are qualified appropriately. The same is true for type expressions.
-- When an interface is imported, the compiler first transforms the
-- interface into these environments. If an import specification is
-- present, the environments are restricted to only those entities which
-- are included in the specification or not hidden by it, respectively.
-- The resulting environments are then imported into the current module
-- using either a qualified import (if the module is imported qualified)
-- or both a qualified and an unqualified import (non-qualified import).
-- Regardless of the type of import, all instance declarations are always
-- imported into the current module.
importInterface :: ModuleIdent -> Bool -> Maybe ImportSpec -> Interface
-> CompilerEnv -> CompilerEnv
importInterface m q is (Interface mid _ ds) env = env'
where
env' = env
{ opPrecEnv = importEntities (precs mid) m q vs id ds $ opPrecEnv env
, tyConsEnv = importEntities (types mid) m q ts (importData vs) ds $ tyConsEnv env
, valueEnv = importEntities (values mid) m q vs id ds $ valueEnv env
, classEnv = importClasses mid ds $ classEnv env
, instEnv = importInstances mid ds $ instEnv env
}
ts = isVisible addType is
vs = isVisible addValue is
addType :: Import -> [Ident] -> [Ident]
addType (Import _ _) tcs = tcs
addType (ImportTypeWith _ tc _) tcs = tc : tcs
addType (ImportTypeAll _ _) _ = internalError "Imports.addType"
addValue :: Import -> [Ident] -> [Ident]
addValue (Import _ f) fs = f : fs
addValue (ImportTypeWith _ _ cs) fs = cs ++ fs
addValue (ImportTypeAll _ _) _ = internalError "Imports.addValue"
isVisible :: (Import -> [Ident] -> [Ident]) -> Maybe ImportSpec
-> Ident -> Bool
isVisible _ Nothing = const True
isVisible add (Just (Importing _ xs)) = (`Set.member` Set.fromList (foldr add [] xs))
isVisible add (Just (Hiding _ xs)) = (`Set.notMember` Set.fromList (foldr add [] xs))
importEntities :: Entity a => (IDecl -> [a]) -> ModuleIdent -> Bool
-> (Ident -> Bool) -> (a -> a) -> [IDecl] -> TopEnv a -> TopEnv a
importEntities ents m q isVisible' f ds env =
foldr (uncurry (if q then qualImportTopEnv m else importUnqual m)) env
[ (x, f y) | y <- concatMap ents ds
, let x = unqualify (origName y), isVisible' x
]
where importUnqual m' x y = importTopEnv m' x y . qualImportTopEnv m' x y
importData :: (Ident -> Bool) -> TypeInfo -> TypeInfo
importData isVisible' (DataType tc k cs) =
DataType tc k $ catMaybes $ map (importConstr isVisible') cs
importData isVisible' (RenamingType tc k nc) =
maybe (DataType tc k []) (RenamingType tc k) (importConstr isVisible' nc)
importData _ (AliasType tc k n ty) = AliasType tc k n ty
importData isVisible' (TypeClass qcls k ms) =
TypeClass qcls k $ catMaybes $ map (importMethod isVisible') ms
importData _ (TypeVar _) = internalError "Imports.importData: type variable"
importConstr :: (Ident -> Bool) -> DataConstr -> Maybe DataConstr
importConstr isVisible' dc
| isVisible' (constrIdent dc) = Just dc
| otherwise = Nothing
importMethod :: (Ident -> Bool) -> ClassMethod -> Maybe ClassMethod
importMethod isVisible' mthd
| isVisible' (methodName mthd) = Just mthd
| otherwise = Nothing
importClasses :: ModuleIdent -> [IDecl] -> ClassEnv -> ClassEnv
importClasses m = flip $ foldr (bindClass m)
bindClass :: ModuleIdent -> IDecl -> ClassEnv -> ClassEnv
bindClass m (HidingClassDecl p cx cls k tv) =
bindClass m (IClassDecl p cx cls k tv [] [])
bindClass m (IClassDecl _ cx cls _ _ ds ids) =
bindClassInfo (qualQualify m cls) (sclss, ms)
where sclss = map (\(Constraint _ scls _) -> qualQualify m scls) cx
ms = map (\d -> (imethod d, isJust $ imethodArity d)) $ filter isVis ds
isVis (IMethodDecl _ idt _ _ ) = idt `notElem` ids
bindClass _ _ = id
importInstances :: ModuleIdent -> [IDecl] -> InstEnv -> InstEnv
importInstances m = flip $ foldr (bindInstance m)
bindInstance :: ModuleIdent -> IDecl -> InstEnv -> InstEnv
bindInstance m (IInstanceDecl _ cx qcls ty is mm) = bindInstInfo
(qualQualify m qcls, qualifyTC m $ typeConstr ty) (fromMaybe m mm, ps, is)
where PredType ps _ = toQualPredType m [] $ QualTypeExpr NoSpanInfo cx ty
bindInstance _ _ = id
-- ---------------------------------------------------------------------------
-- Building the initial environment
-- ---------------------------------------------------------------------------
-- In a first step, the four export environments are initialized from
-- the interface's declarations.
-- operator precedences
precs :: ModuleIdent -> IDecl -> [PrecInfo]
precs m (IInfixDecl _ fix prec op) = [PrecInfo (qualQualify m op) (OpPrec fix prec)]
precs _ _ = []
hiddenTypes :: ModuleIdent -> IDecl -> [TypeInfo]
hiddenTypes m (HidingDataDecl _ tc k tvs) = [typeCon DataType m tc k tvs []]
hiddenTypes m (HidingClassDecl _ _ qcls k _) = [typeCls m qcls k []]
hiddenTypes m d = types m d
-- type constructors and type classes
types :: ModuleIdent -> IDecl -> [TypeInfo]
types m (IDataDecl _ tc k tvs cs _) =
[typeCon DataType m tc k tvs (map mkData cs)]
where
mkData (ConstrDecl _ c tys) =
DataConstr c (toQualTypes m tvs tys)
mkData (ConOpDecl _ ty1 c ty2) =
DataConstr c (toQualTypes m tvs [ty1, ty2])
mkData (RecordDecl _ c fs) =
RecordConstr c labels (toQualTypes m tvs tys)
where (labels, tys) = unzip [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
types m (INewtypeDecl _ tc k tvs nc _) =
[typeCon RenamingType m tc k tvs (mkData nc)]
where
mkData (NewConstrDecl _ c ty) =
DataConstr c [toQualType m tvs ty]
mkData (NewRecordDecl _ c (l, ty)) =
RecordConstr c [l] [toQualType m tvs ty]
types m (ITypeDecl _ tc k tvs ty) =
[typeCon aliasType m tc k tvs (toQualType m tvs ty)]
where
aliasType tc' k' = AliasType tc' k' (length tvs)
types m (IClassDecl _ _ qcls k tv ds ids) =
[typeCls m qcls k (map mkMethod $ filter isVis ds)]
where
isVis (IMethodDecl _ f _ _ ) = f `notElem` ids
mkMethod (IMethodDecl _ f a qty) = ClassMethod f a $
qualifyPredType m $ normalize 1 $ toMethodType qcls tv qty
types _ _ = []
-- type constructors
typeCon :: (QualIdent -> Kind -> a) -> ModuleIdent -> QualIdent
-> Maybe KindExpr -> [Ident] -> a
typeCon f m tc k tvs = f (qualQualify m tc) (toKind' k (length tvs))
-- type classes
typeCls :: ModuleIdent -> QualIdent -> Maybe KindExpr -> [ClassMethod]
-> TypeInfo
typeCls m qcls k ms = TypeClass (qualQualify m qcls) (toKind' k 0) ms
-- data constructors, record labels, functions and class methods
values :: ModuleIdent -> IDecl -> [ValueInfo]
values m (IDataDecl _ tc _ tvs cs hs) =
map (dataConstr m tc' tvs)
(filter ((\con -> con `notElem` hs || isHiddenButNeeded con)
. constrId) cs) ++
map (recLabel m tc' tvs ty') (nubBy sameLabel clabels)
where tc' = qualQualify m tc
ty' = constrType tc' tvs
labels = [ (l, lty) | RecordDecl _ _ fs <- cs
, FieldDecl _ ls lty <- fs, l <- ls, l `notElem` hs
]
clabels = [(l, constr l, ty) | (l, ty) <- labels]
constr l = [constrId c | c <- cs, l `elem` recordLabels c]
-- hidden constructors needed for record updates with visible labels
hiddenCs = [c | (l, _) <- labels, c <- constr l, c `elem` hs]
isHiddenButNeeded = flip elem hiddenCs
sameLabel (l1,_,_) (l2,_,_) = l1 == l2
values m (INewtypeDecl _ tc _ tvs nc hs) =
map (newConstr m tc' tvs) [nc | nconstrId nc `notElem` hs] ++
case nc of
NewConstrDecl _ _ _ -> []
NewRecordDecl _ c (l, lty) ->
[recLabel m tc' tvs ty' (l, [c], lty) | l `notElem` hs]
where tc' = qualQualify m tc
ty' = constrType tc' tvs
values m (IFunctionDecl _ f Nothing a qty) =
[Value (qualQualify m f) Nothing a (typeScheme (toQualPredType m [] qty))]
values m (IFunctionDecl _ f (Just tv) _ qty) =
let mcls = case qty of
QualTypeExpr _ ctx _ -> fmap (\(Constraint _ qcls _) -> qcls) $
find (\(Constraint _ _ ty) -> isVar ty) ctx
in [Value (qualQualify m f) mcls 0 (typeScheme (toQualPredType m [tv] qty))]
where
isVar (VariableType _ i) = i == tv
isVar _ = False
values m (IClassDecl _ _ qcls _ tv ds hs) =
map (classMethod m qcls' tv hs) ds
where qcls' = qualQualify m qcls
values _ _ = []
dataConstr :: ModuleIdent -> QualIdent -> [Ident] -> ConstrDecl -> ValueInfo
dataConstr m tc tvs (ConstrDecl _ c tys) =
DataConstructor (qualifyLike tc c) a labels $
constrType' m tc tvs tys
where a = length tys
labels = replicate a anonId
dataConstr m tc tvs (ConOpDecl _ ty1 op ty2) =
DataConstructor (qualifyLike tc op) 2 [anonId, anonId] $
constrType' m tc tvs [ty1, ty2]
dataConstr m tc tvs (RecordDecl _ c fs) =
DataConstructor (qualifyLike tc c) a labels $
constrType' m tc tvs tys
where fields = [(l, ty) | FieldDecl _ ls ty <- fs, l <- ls]
(labels, tys) = unzip fields
a = length labels
newConstr :: ModuleIdent -> QualIdent -> [Ident] -> NewConstrDecl -> ValueInfo
newConstr m tc tvs (NewConstrDecl _ c ty1) =
NewtypeConstructor (qualifyLike tc c) anonId $
constrType' m tc tvs [ty1]
newConstr m tc tvs (NewRecordDecl _ c (l, ty1)) =
NewtypeConstructor (qualifyLike tc c) l $
constrType' m tc tvs [ty1]
recLabel :: ModuleIdent -> QualIdent -> [Ident] -> TypeExpr
-> (Ident, [Ident], TypeExpr) -> ValueInfo
recLabel m tc tvs ty0 (l, cs, lty) = Label ql qcs tySc
where ql = qualifyLike tc l
qcs = map (qualifyLike tc) cs
tySc = polyType (toQualType m tvs (ArrowType NoSpanInfo ty0 lty))
constrType' :: ModuleIdent -> QualIdent -> [Ident] -> [TypeExpr] -> TypeScheme
constrType' m tc tvs tys = ForAll (length tvs) pty
where pty = qualifyPredType m $ toConstrType tc tvs tys
constrType :: QualIdent -> [Ident] -> TypeExpr
constrType tc tvs = foldl (ApplyType NoSpanInfo) (ConstructorType NoSpanInfo tc)
$ map (VariableType NoSpanInfo) tvs
-- We always enter class methods with an arity of 0 into the value environment
-- because there may be different implementations with different arities.
classMethod :: ModuleIdent -> QualIdent -> Ident -> [Ident] -> IMethodDecl
-> ValueInfo
classMethod m qcls tv hs (IMethodDecl _ f _ qty) =
Value (qualifyLike qcls f) mcls 0 $
typeScheme $ qualifyPredType m $ toMethodType qcls tv qty
where
mcls = if f `elem` hs then Nothing else Just qcls
-- ---------------------------------------------------------------------------
-- After all modules have been imported, the compiler has to ensure that
-- all references to a data type use the same list of constructors.
importUnifyData :: CompilerEnv -> CompilerEnv
importUnifyData cEnv = cEnv { tyConsEnv = importUnifyData' $ tyConsEnv cEnv }
importUnifyData' :: TCEnv -> TCEnv
importUnifyData' tcEnv = fmap (setInfo allTyCons) tcEnv
where
setInfo tcs t = case Map.lookup (origName t) tcs of
Nothing -> error "Imports.importUnifyData'"
Just ty -> ty
allTyCons = foldr (mergeData . snd) Map.empty $ allImports tcEnv
mergeData t tcs =
Map.insert tc (maybe t (sureMerge t) $ Map.lookup tc tcs) tcs
where tc = origName t
sureMerge x y = case merge x y of
Nothing -> error "Imports.importUnifyData'.sureMerge"
Just z -> z
-- ---------------------------------------------------------------------------
-- |
qualifyEnv :: CompilerEnv -> CompilerEnv
qualifyEnv env = qualifyLocal env
$ foldl (flip importInterfaceIntf) initEnv
$ Map.elems
$ interfaceEnv env
where initEnv = initCompilerEnv $ moduleIdent env
qualifyLocal :: CompilerEnv -> CompilerEnv -> CompilerEnv
qualifyLocal currentEnv initEnv = currentEnv
{ opPrecEnv = foldr bindQual pEnv $ localBindings $ opPrecEnv currentEnv
, tyConsEnv = foldr bindQual tcEnv $ localBindings $ tyConsEnv currentEnv
, valueEnv = foldr bindGlobal tyEnv $ localBindings $ valueEnv currentEnv
, classEnv = Map.unionWith mergeClassInfo clsEnv $ classEnv currentEnv
, instEnv = Map.union iEnv $ instEnv currentEnv
}
where
pEnv = opPrecEnv initEnv
tcEnv = tyConsEnv initEnv
tyEnv = valueEnv initEnv
clsEnv = classEnv initEnv
iEnv = instEnv initEnv
bindQual (_, y) = qualBindTopEnv (origName y) y
bindGlobal (x, y)
| hasGlobalScope x = bindQual (x, y)
| otherwise = bindTopEnv x y
-- Importing an interface into another interface is somewhat simpler
-- because all entities are imported into the environment. In addition,
-- only a qualified import is necessary. Note that the hidden data types
-- are imported as well because they may be used in type expressions in
-- an interface.
importInterfaceIntf :: Interface -> CompilerEnv -> CompilerEnv
importInterfaceIntf (Interface m _ ds) env = env
{ opPrecEnv = importEntitiesIntf m (precs m) ds $ opPrecEnv env
, tyConsEnv = importEntitiesIntf m (hiddenTypes m) ds $ tyConsEnv env
, valueEnv = importEntitiesIntf m (values m) ds $ valueEnv env
, classEnv = importClasses m ds $ classEnv env
, instEnv = importInstances m ds $ instEnv env
}
importEntitiesIntf :: Entity a => ModuleIdent -> (IDecl -> [a]) -> [IDecl]
-> TopEnv a -> TopEnv a
importEntitiesIntf m ents ds env = foldr importEntity env (concatMap ents ds)
where importEntity x = qualImportTopEnv (fromMaybe m (qidModule (origName x)))
(unqualify (origName x)) x