{- | Module : $Header$ Description : Computation of export interface Copyright : (c) 2000 - 2004 Wolfgang Lux 2005 Martin Engelke 2011 - 2016 Björn Peemöller 2015 Jan Tikovsky 2016 Finn Teegen License : BSD-3-clause Maintainer : bjp@informatik.uni-kiel.de Stability : experimental Portability : portable This module provides the computation of the exported interface of a compiled module. The function 'exportInterface' uses the expanded export specifications and the corresponding environments in order to compute the interface of the module. -} module Exports (exportInterface) where import Data.List (nub) import qualified Data.Map as Map (foldrWithKey, toList) import Data.Maybe (mapMaybe) import qualified Data.Set as Set ( Set, empty, insert, deleteMin, fromList , member, toList ) import Curry.Base.Position import Curry.Base.SpanInfo import Curry.Base.Ident import Curry.Syntax import Base.CurryKinds (fromKind') import Base.CurryTypes (fromQualType, fromQualPredType) import Base.Messages import Base.Types import Env.Class import Env.OpPrec (OpPrecEnv, PrecInfo (..), OpPrec (..), qualLookupP) import Env.Instance import Env.TypeConstructor ( TCEnv, TypeInfo (..), tcKind, clsKind , qualLookupTypeInfo ) import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) import CompilerEnv import Base.Kinds -- --------------------------------------------------------------------------- -- Computation of the interface -- --------------------------------------------------------------------------- -- After checking that the interface is not ambiguous, the compiler -- generates the interface's declarations from the list of exported -- functions and values. In order to make the interface more stable -- against private changes in the module, we remove the hidden data -- constructors of a data type in the interface when they occur -- right-most in the declaration. In addition, newtypes whose constructor -- is not exported are transformed into (abstract) data types. -- -- If a type is imported from another module, its name is qualified with -- the name of the module where it is defined. The same applies to an -- exported function. exportInterface :: CompilerEnv -> Module a -> Interface exportInterface env (Module _ _ m (Just (Exporting _ es)) _ _) = exportInterface' m es (opPrecEnv env) (tyConsEnv env) (valueEnv env) (classEnv env) (instEnv env) exportInterface _ (Module _ _ _ Nothing _ _) = internalError "Exports.exportInterface: no export specification" exportInterface' :: ModuleIdent -> [Export] -> OpPrecEnv -> TCEnv -> ValueEnv -> ClassEnv -> InstEnv -> Interface exportInterface' m es pEnv tcEnv vEnv clsEnv inEnv = Interface m imports decls' where tvs = filter (`notElem` tcs) identSupply tcs = mapMaybe (localIdent m) $ definedTypes decls' imports = map (IImportDecl NoPos) $ usedModules decls' precs = foldr (infixDecl m pEnv) [] es types = foldr (typeDecl m tcEnv clsEnv tvs) [] es values = foldr (valueDecl m vEnv tvs) [] es insts = Map.foldrWithKey (instDecl m tcEnv tvs) [] inEnv decls = precs ++ types ++ values ++ insts decls' = closeInterface m tcEnv clsEnv inEnv tvs Set.empty decls infixDecl :: ModuleIdent -> OpPrecEnv -> Export -> [IDecl] -> [IDecl] infixDecl m pEnv (Export _ f) ds = iInfixDecl m pEnv f ds infixDecl m pEnv (ExportTypeWith _ tc cs) ds = foldr (iInfixDecl m pEnv . qualifyLike tc) ds cs infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match" iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl] iInfixDecl m pEnv op ds = case qualLookupP op pEnv of [] -> ds [PrecInfo _ (OpPrec f p)] -> IInfixDecl NoPos f p (qualUnqualify m op) : ds _ -> internalError "Exports.infixDecl" -- Data types and renaming types whose constructors and field labels are -- not exported are exported as abstract types, i.e., their constructors -- do not appear in the interface. If only some constructors or field -- labels of a type are not exported all constructors appear in the -- interface, but a pragma marks the constructors and field labels which -- are not exported as hidden to prevent their use in user code. typeDecl :: ModuleIdent -> TCEnv -> ClassEnv -> [Ident] -> Export -> [IDecl] -> [IDecl] typeDecl _ _ _ _ (Export _ _) ds = ds typeDecl m tcEnv clsEnv tvs (ExportTypeWith _ tc xs) ds = case qualLookupTypeInfo tc tcEnv of [DataType tc' k cs] | null xs -> iTypeDecl IDataDecl m tvs tc' k [] [] : ds | otherwise -> iTypeDecl IDataDecl m tvs tc' k cs' hs : ds where hs = filter (`notElem` xs) (csIds ++ ls) cs' = map (constrDecl m n tvs) cs ls = nub (concatMap recordLabels cs') csIds = map constrIdent cs n = kindArity k [RenamingType tc' k c] | null xs -> iTypeDecl IDataDecl m tvs tc' k [] [] : ds | otherwise -> iTypeDecl INewtypeDecl m tvs tc' k nc hs : ds where hs = filter (`notElem` xs) (cId : ls) nc = newConstrDecl m tvs c ls = nrecordLabels nc cId = constrIdent c [AliasType tc' k n ty] -> ITypeDecl NoPos tc'' k' tvs' ty' : ds where tc'' = qualUnqualify m tc' k' = fromKind' k n tvs' = take n tvs ty' = fromQualType m tvs' ty [TypeClass qcls k ms] -> IClassDecl NoPos cx qcls' k' tv ms' hs : ds where qcls' = qualUnqualify m qcls cx = [ Constraint NoSpanInfo (qualUnqualify m scls) (VariableType NoSpanInfo tv) | scls <- superClasses qcls clsEnv ] k' = fromKind' k 0 tv = head tvs ms' = map (methodDecl m tvs) ms hs = filter (`notElem` xs) (map methodName ms) _ -> internalError "Exports.typeDecl" typeDecl _ _ _ _ _ _ = internalError "Exports.typeDecl: no pattern match" iTypeDecl :: (Position -> QualIdent -> Maybe KindExpr -> [Ident] -> a -> [Ident] -> IDecl) -> ModuleIdent -> [Ident] -> QualIdent -> Kind -> a -> [Ident] -> IDecl iTypeDecl f m tvs tc k x hs = f NoPos (qualUnqualify m tc) k' (take n tvs) x hs where n = kindArity k k' = fromKind' k n constrDecl :: ModuleIdent -> Int -> [Ident] -> DataConstr -> ConstrDecl constrDecl m _ tvs (DataConstr c [ty1, ty2]) | isInfixOp c = ConOpDecl NoSpanInfo ty1' c ty2' where [ty1', ty2'] = map (fromQualType m tvs) [ty1, ty2] constrDecl m _ tvs (DataConstr c tys) = ConstrDecl NoSpanInfo c tys' where tys' = map (fromQualType m tvs) tys constrDecl m _ tvs (RecordConstr c ls tys) = RecordDecl NoSpanInfo c fs where tys' = map (fromQualType m tvs) tys fs = zipWith (FieldDecl NoSpanInfo . return) ls tys' newConstrDecl :: ModuleIdent -> [Ident] -> DataConstr -> NewConstrDecl newConstrDecl m tvs (DataConstr c tys) = NewConstrDecl NoSpanInfo c (fromQualType m tvs (head tys)) newConstrDecl m tvs (RecordConstr c ls tys) = NewRecordDecl NoSpanInfo c (head ls, fromQualType m tvs (head tys)) -- When exporting a class method, we have to remove the implicit class context. -- Due to the sorting of the predicate set, this is fortunatly very easy. The -- implicit class context is always the minimum element as the class variable -- is assigned the index 0 and no other constraints on it are allowed. methodDecl :: ModuleIdent -> [Ident] -> ClassMethod -> IMethodDecl methodDecl m tvs (ClassMethod f a (PredType ps ty)) = IMethodDecl NoPos f a $ fromQualPredType m tvs $ PredType (Set.deleteMin ps) ty valueDecl :: ModuleIdent -> ValueEnv -> [Ident] -> Export -> [IDecl] -> [IDecl] valueDecl m vEnv tvs (Export _ f) ds = case qualLookupValue f vEnv of [Value _ cm a (ForAll _ pty)] -> IFunctionDecl NoPos (qualUnqualify m f) (if cm then Just (head tvs) else Nothing) a (fromQualPredType m tvs pty) : ds _ -> internalError $ "Exports.valueDecl: " ++ show f valueDecl _ _ _ (ExportTypeWith _ _ _) ds = ds valueDecl _ _ _ _ _ = internalError "Exports.valueDecl: no pattern match" instDecl :: ModuleIdent -> TCEnv -> [Ident] -> InstIdent -> InstInfo -> [IDecl] -> [IDecl] instDecl m tcEnv tvs ident@(cls, tc) info@(m', _, _) ds | qidModule cls /= Just m' && qidModule tc /= Just m' = iInstDecl m tcEnv tvs ident info : ds | otherwise = ds iInstDecl :: ModuleIdent -> TCEnv -> [Ident] -> InstIdent -> InstInfo -> IDecl iInstDecl m tcEnv tvs (cls, tc) (m', ps, is) = IInstanceDecl NoPos cx (qualUnqualify m cls) ty is mm where pty = PredType ps $ applyType (TypeConstructor tc) $ map TypeVariable [0 .. n-1] QualTypeExpr _ cx ty = fromQualPredType m tvs pty n = kindArity (tcKind m tc tcEnv) - kindArity (clsKind m cls tcEnv) mm = if m == m' then Nothing else Just m' -- The compiler determines the list of imported modules from the set of -- module qualifiers that are used in the interface. Careful readers -- probably will have noticed that the functions above carefully strip -- the module prefix from all entities that are defined in the current -- module. Note that the list of modules returned from -- 'usedModules' is not necessarily a subset of the modules that -- were imported into the current module. This will happen when an -- imported module re-exports entities from another module. E.g., given -- the three modules -- -- @ -- module A where { data A = A; } -- module B(A(..)) where { import A; } -- module C where { import B; x = A; } -- @ -- -- the interface for module @C@ will import module @A@ but not module @B@. usedModules :: [IDecl] -> [ModuleIdent] usedModules ds = nub' (modules ds []) where nub' = Set.toList . Set.fromList class HasModule a where modules :: a -> [ModuleIdent] -> [ModuleIdent] instance HasModule a => HasModule (Maybe a) where modules = maybe id modules instance HasModule a => HasModule [a] where modules xs ms = foldr modules ms xs instance HasModule IDecl where modules (IInfixDecl _ _ _ op) = modules op modules (HidingDataDecl _ tc _ _) = modules tc modules (IDataDecl _ tc _ _ cs _) = modules tc . modules cs modules (INewtypeDecl _ tc _ _ nc _) = modules tc . modules nc modules (ITypeDecl _ tc _ _ ty) = modules tc . modules ty modules (IFunctionDecl _ f _ _ qty) = modules f . modules qty modules (HidingClassDecl _ cx cls _ _) = modules cx . modules cls modules (IClassDecl _ cx cls _ _ ms _) = modules cx . modules cls . modules ms modules (IInstanceDecl _ cx cls ty _ mm) = modules cx . modules cls . modules ty . modules mm instance HasModule ConstrDecl where modules (ConstrDecl _ _ tys) = modules tys modules (ConOpDecl _ ty1 _ ty2) = modules ty1 . modules ty2 modules (RecordDecl _ _ fs) = modules fs instance HasModule FieldDecl where modules (FieldDecl _ _ ty) = modules ty instance HasModule NewConstrDecl where modules (NewConstrDecl _ _ ty) = modules ty modules (NewRecordDecl _ _ (_, ty)) = modules ty instance HasModule IMethodDecl where modules (IMethodDecl _ _ _ qty) = modules qty instance HasModule Constraint where modules (Constraint _ cls ty) = modules cls . modules ty instance HasModule TypeExpr where modules (ConstructorType _ tc) = modules tc modules (ApplyType _ ty1 ty2) = modules ty1 . modules ty2 modules (VariableType _ _) = id modules (TupleType _ tys) = modules tys modules (ListType _ ty) = modules ty modules (ArrowType _ ty1 ty2) = modules ty1 . modules ty2 modules (ParenType _ ty) = modules ty modules (ForallType _ _ ty) = modules ty instance HasModule QualTypeExpr where modules (QualTypeExpr _ cx ty) = modules cx . modules ty instance HasModule QualIdent where modules = modules . qidModule instance HasModule ModuleIdent where modules = (:) -- After the interface declarations have been computed, the compiler -- eventually must add hidden (data) type and class declarations to the -- interface for all those types and classs which were used in the interface -- but not exported from the current module, so that these type constructors -- can always be distinguished from type variables. Besides hidden type and -- class declarations, the compiler also adds instance declarations to the -- interface. Since class and instance declarations added to an interface can -- require the inclusion of further classes by their respective contexts, -- closing an interface is implemented as a fix-point computation which -- starts from the initial interface. data IInfo = IOther | IType QualIdent | IClass QualIdent | IInst InstIdent deriving (Eq, Ord) iInfo :: IDecl -> IInfo iInfo (IInfixDecl _ _ _ _) = IOther iInfo (HidingDataDecl _ tc _ _) = IType tc iInfo (IDataDecl _ tc _ _ _ _) = IType tc iInfo (INewtypeDecl _ tc _ _ _ _) = IType tc iInfo (ITypeDecl _ _ _ _ _) = IOther iInfo (HidingClassDecl _ _ cls _ _) = IClass cls iInfo (IClassDecl _ _ cls _ _ _ _) = IClass cls iInfo (IInstanceDecl _ _ cls ty _ _) = IInst (cls, typeConstr ty) iInfo (IFunctionDecl _ _ _ _ _) = IOther closeInterface :: ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> [Ident] -> Set.Set IInfo -> [IDecl] -> [IDecl] closeInterface _ _ _ _ _ _ [] = [] closeInterface m tcEnv clsEnv inEnv tvs is (d:ds) | i == IOther = d : closeInterface m tcEnv clsEnv inEnv tvs is (ds ++ ds') | i `Set.member` is = closeInterface m tcEnv clsEnv inEnv tvs is ds | otherwise = d : closeInterface m tcEnv clsEnv inEnv tvs (Set.insert i is) (ds ++ ds') where i = iInfo d ds' = hiddenTypes m tcEnv clsEnv tvs d ++ instances m tcEnv inEnv tvs is i hiddenTypes :: ModuleIdent -> TCEnv -> ClassEnv -> [Ident] -> IDecl -> [IDecl] hiddenTypes m tcEnv clsEnv tvs d = map hiddenTypeDecl $ filter (not . isPrimTypeId) (usedTypes d []) where hiddenTypeDecl tc = case qualLookupTypeInfo (qualQualify m tc) tcEnv of [DataType _ k _] -> hidingDataDecl k [RenamingType _ k _] -> hidingDataDecl k [TypeClass cls k _] -> hidingClassDecl k $ superClasses cls clsEnv _ -> internalError $ "Exports.hiddenTypeDecl: " ++ show tc where hidingDataDecl k = let n = kindArity k k' = fromKind' k n in HidingDataDecl NoPos tc k' $ take n tvs hidingClassDecl k sclss = let cx = [ Constraint NoSpanInfo (qualUnqualify m scls) (VariableType NoSpanInfo tv) | scls <- sclss ] tv = head tvs k' = fromKind' k 0 in HidingClassDecl NoPos cx tc k' tv instances :: ModuleIdent -> TCEnv -> InstEnv -> [Ident] -> Set.Set IInfo -> IInfo -> [IDecl] instances _ _ _ _ _ IOther = [] instances m tcEnv inEnv tvs is (IType tc) = [ iInstDecl m tcEnv tvs ident info | (ident@(cls, tc'), info@(m', _, _)) <- Map.toList inEnv, qualQualify m tc == tc', if qidModule cls == Just m' then Set.member (IClass (qualUnqualify m cls)) is else qidModule tc' == Just m' ] instances m tcEnv inEnv tvs is (IClass cls) = [ iInstDecl m tcEnv tvs ident info | (ident@(cls', tc), info@(m', _, _)) <- Map.toList inEnv, qualQualify m cls == cls', qidModule cls' == Just m', m /= m' || isPrimTypeId tc || qidModule tc /= Just m || Set.member (IType (qualUnqualify m tc)) is ] instances _ _ _ _ _ (IInst _) = [] definedTypes :: [IDecl] -> [QualIdent] definedTypes ds = foldr definedType [] ds where definedType :: IDecl -> [QualIdent] -> [QualIdent] definedType (HidingDataDecl _ tc _ _) tcs = tc : tcs definedType (IDataDecl _ tc _ _ _ _) tcs = tc : tcs definedType (INewtypeDecl _ tc _ _ _ _) tcs = tc : tcs definedType (ITypeDecl _ tc _ _ _ ) tcs = tc : tcs definedType (HidingClassDecl _ _ cls _ _) tcs = cls : tcs definedType (IClassDecl _ _ cls _ _ _ _) tcs = cls : tcs definedType _ tcs = tcs class HasType a where usedTypes :: a -> [QualIdent] -> [QualIdent] instance HasType a => HasType (Maybe a) where usedTypes = maybe id usedTypes instance HasType a => HasType [a] where usedTypes xs tcs = foldr usedTypes tcs xs instance HasType IDecl where usedTypes (IInfixDecl _ _ _ _) = id usedTypes (HidingDataDecl _ _ _ _) = id usedTypes (IDataDecl _ _ _ _ cs _) = usedTypes cs usedTypes (INewtypeDecl _ _ _ _ nc _) = usedTypes nc usedTypes (ITypeDecl _ _ _ _ ty) = usedTypes ty usedTypes (IFunctionDecl _ _ _ _ qty) = usedTypes qty usedTypes (HidingClassDecl _ cx _ _ _) = usedTypes cx usedTypes (IClassDecl _ cx _ _ _ ms _) = usedTypes cx . usedTypes ms usedTypes (IInstanceDecl _ cx cls ty _ _) = usedTypes cx . (cls :) . usedTypes ty instance HasType ConstrDecl where usedTypes (ConstrDecl _ _ tys) = usedTypes tys usedTypes (ConOpDecl _ ty1 _ ty2) = usedTypes ty1 . usedTypes ty2 usedTypes (RecordDecl _ _ fs) = usedTypes fs instance HasType FieldDecl where usedTypes (FieldDecl _ _ ty) = usedTypes ty instance HasType NewConstrDecl where usedTypes (NewConstrDecl _ _ ty) = usedTypes ty usedTypes (NewRecordDecl _ _ (_, ty)) = usedTypes ty instance HasType IMethodDecl where usedTypes (IMethodDecl _ _ _ qty) = usedTypes qty instance HasType Constraint where usedTypes (Constraint _ cls ty) = (cls :) . usedTypes ty instance HasType TypeExpr where usedTypes (ConstructorType _ tc) = (tc :) usedTypes (ApplyType _ ty1 ty2) = usedTypes ty1 . usedTypes ty2 usedTypes (VariableType _ _) = id usedTypes (TupleType _ tys) = usedTypes tys usedTypes (ListType _ ty) = usedTypes ty usedTypes (ArrowType _ ty1 ty2) = usedTypes ty1 . usedTypes ty2 usedTypes (ParenType _ ty) = usedTypes ty usedTypes (ForallType _ _ ty) = usedTypes ty instance HasType QualTypeExpr where usedTypes (QualTypeExpr _ cx ty) = usedTypes cx . usedTypes ty