Exports.hs 11.6 KB
Newer Older
1 2
{- |
    Module      :  $Header$
3
    Description :  Computation of export interface
4 5 6
    Copyright   :  (c) 2000 - 2004, Wolfgang Lux
                       2005       , Martin Engelke
                       2011 - 2013, Björn Peemöller
7
                       2015       , Jan Tikovsky
8 9 10 11 12 13 14
    License     :  OtherLicense

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

    This module provides the computation of the exported interface of a
15 16 17
    compiled module. The function 'exportInterface' uses the expanded export
    specifications and the corresponding environments in order to compute
    the interface of the module.
18
-}
19
module Exports (exportInterface) where
20

21 22
import           Data.List         (nub)
import           Data.Maybe        (catMaybes)
Björn Peemöller 's avatar
Björn Peemöller committed
23
import qualified Data.Set   as Set (delete, fromList, toList)
24 25 26 27 28 29 30 31 32

import Curry.Base.Position
import Curry.Base.Ident
import Curry.Syntax

import Base.CurryTypes (fromQualType)
import Base.Messages
import Base.Types

Björn Peemöller 's avatar
Björn Peemöller committed
33
import Env.OpPrec          (OpPrecEnv, PrecInfo (..), OpPrec (..), qualLookupP)
34
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
Björn Peemöller 's avatar
Björn Peemöller committed
35
import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValue)
36 37 38

import CompilerEnv

39 40 41
-- ---------------------------------------------------------------------------
-- Computation of the interface
-- ---------------------------------------------------------------------------
42 43 44 45 46 47 48 49

-- 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.
50
--
51 52 53 54 55 56 57 58
-- 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 -> Interface
exportInterface env mdl = exportInterface' mdl
  (opPrecEnv env) (tyConsEnv env) (valueEnv env)

Björn Peemöller 's avatar
Björn Peemöller committed
59
exportInterface' :: Module -> OpPrecEnv -> TCEnv -> ValueEnv -> Interface
60
exportInterface' (Module _ m (Just (Exporting _ es)) _ _) pEnv tcEnv tyEnv
61 62 63 64
  = Interface m imports $ precs ++ hidden ++ decls
  where
  imports = map   (IImportDecl NoPos) $ usedModules decls
  precs   = foldr (infixDecl m pEnv) [] es
65
  hidden  = map   (hiddenTypeDecl m tcEnv) $ hiddenTypes m decls
66
  decls   = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es
67
exportInterface' (Module _ _ Nothing _ _) _ _ _
68 69
  = internalError "Exports.exportInterface: no export specification"

Björn Peemöller 's avatar
Björn Peemöller committed
70
infixDecl :: ModuleIdent -> OpPrecEnv -> Export -> [IDecl] -> [IDecl]
71 72
infixDecl m pEnv (Export             f) ds = iInfixDecl m pEnv f ds
infixDecl m pEnv (ExportTypeWith tc cs) ds =
73
  foldr (iInfixDecl m pEnv . qualifyLike tc) ds cs
74
infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match"
75

Björn Peemöller 's avatar
Björn Peemöller committed
76
iInfixDecl :: ModuleIdent -> OpPrecEnv -> QualIdent -> [IDecl] -> [IDecl]
77 78 79
iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
  []                           -> ds
  [PrecInfo _ (OpPrec fix pr)] ->
80
    IInfixDecl NoPos fix pr (qualUnqualify m op) : ds
81 82
  _                            -> internalError "Exports.infixDecl"

83 84 85 86 87 88 89
-- 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.

90 91
typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
typeDecl _ _     (Export             _) ds = ds
92 93 94 95 96
typeDecl m tcEnv (ExportTypeWith tc xs) ds = case qualLookupTC tc tcEnv of
  [DataType tc' n cs]
    | null xs   -> iTypeDecl IDataDecl m tc' n []  []  : ds
    | otherwise -> iTypeDecl IDataDecl m tc' n cs' hs : ds
    where hs    = filter (`notElem` xs) (csIds ++ ls)
97
          cs'   = map (constrDecl m (drop n identSupply)) cs
98 99 100
          ls    = nub (concatMap recordLabels cs')
          csIds = map constrIdent cs
  [RenamingType tc' n c]
101 102
    | null xs   -> iTypeDecl IDataDecl m tc' n [] [] : ds
    | otherwise -> iTypeDecl INewtypeDecl m tc' n nc hs : ds
103 104 105 106
    where hs  = filter (`notElem` xs) (cId : ls)
          nc  = newConstrDecl m (drop n identSupply) c
          ls  = nrecordLabels nc
          cId = constrIdent c
107 108 109 110
  [AliasType tc' n ty] -> ITypeDecl NoPos tc'' tvs ty' : ds
    where tc'' = qualUnqualify m tc'
          tvs  = take n identSupply
          ty'  = fromQualType m ty
111
  _ -> internalError "Exports.typeDecl"
112
typeDecl _ _ _ _ = internalError "Exports.typeDecl: no pattern match"
113

114 115 116
iTypeDecl :: (Position -> QualIdent -> [Ident] -> a -> [Ident] -> IDecl)
           -> ModuleIdent -> QualIdent -> Int -> a -> [Ident] -> IDecl
iTypeDecl f m tc n x hs = f NoPos (qualUnqualify m tc) (take n identSupply) x hs
117

118 119 120 121 122 123 124 125 126 127 128 129 130 131
constrDecl :: ModuleIdent -> [Ident] -> DataConstr -> ConstrDecl
constrDecl m tvs (DataConstr c n [ty1,ty2])
  | isInfixOp c = ConOpDecl NoPos evs (fromQualType m ty1) c (fromQualType m ty2)
  where evs = take n tvs
constrDecl m tvs (DataConstr c n tys) = ConstrDecl NoPos evs c tys'
  where evs  = take n tvs
        tys' = map (fromQualType m) tys
constrDecl m tvs (RecordConstr c n ls tys) = RecordDecl NoPos evs c fs
  where
    evs  = take n tvs
    tys' = map (fromQualType m) tys
    fs   = zipWith (FieldDecl NoPos . return) ls tys'

newConstrDecl :: ModuleIdent -> [Ident] -> DataConstr -> NewConstrDecl
132
newConstrDecl m tvs (DataConstr c n tys) = NewConstrDecl NoPos evs c ty'
133
  where evs = take n tvs
134 135 136
        ty' = fromQualType m (head tys)
newConstrDecl m tvs (RecordConstr c n ls tys)
  = NewRecordDecl NoPos evs c (head ls,ty')
137
  where evs = take n tvs
138
        ty' = fromQualType m (head tys)
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156

funDecl :: ModuleIdent -> ValueEnv -> Export -> [IDecl] -> [IDecl]
funDecl m tyEnv (Export f) ds = case qualLookupValue f tyEnv of
  [Value _ a (ForAll _ ty)] ->
    IFunctionDecl NoPos (qualUnqualify m f) a (fromQualType m ty) : ds
  _ -> internalError $ "Exports.funDecl: " ++ show f
funDecl _ _     (ExportTypeWith _ _) ds = ds
funDecl _ _ _ _ = internalError "Exports.funDecl: no pattern match"

-- 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
157
--
158 159 160 161 162
-- @
-- module A where { data A = A; }
-- module B(A(..)) where { import A; }
-- module C where { import B; x = A; }
-- @
163
--
164 165 166
-- the interface for module @C@ will import module @A@ but not module @B@.

usedModules :: [IDecl] -> [ModuleIdent]
167
usedModules ds = nub' (catMaybes (map qidModule (foldr identsDecl [] ds)))
168 169 170
  where nub' = Set.toList . Set.fromList

identsDecl :: IDecl -> [QualIdent] -> [QualIdent]
171 172 173 174 175
identsDecl (IDataDecl    _ tc _ cs _) xs =
  tc : foldr identsConstrDecl xs cs
identsDecl (INewtypeDecl _ tc _ nc _) xs = tc : identsNewConstrDecl nc xs
identsDecl (ITypeDecl      _ tc _ ty) xs = tc : identsType ty xs
identsDecl (IFunctionDecl   _ f _ ty) xs = f  : identsType ty xs
176 177 178 179 180 181
identsDecl _ _ = internalError "Exports.identsDecl: no pattern match"

identsConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
identsConstrDecl (ConstrDecl    _ _ _ tys) xs = foldr identsType xs tys
identsConstrDecl (ConOpDecl _ _ ty1 _ ty2) xs =
  identsType ty1 (identsType ty2 xs)
182 183 184 185
identsConstrDecl (RecordDecl     _ _ _ fs) xs = foldr identsFieldDecl xs fs

identsFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
identsFieldDecl (FieldDecl _ _ ty) xs = identsType ty xs
186 187 188

identsNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
identsNewConstrDecl (NewConstrDecl _ _ _ ty) xs = identsType ty xs
189
identsNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) xs = identsType ty xs
190 191 192 193 194 195 196

identsType :: TypeExpr -> [QualIdent] -> [QualIdent]
identsType (ConstructorType tc tys) xs = tc : foldr identsType xs tys
identsType (VariableType         _) xs = xs
identsType (TupleType          tys) xs = foldr identsType xs tys
identsType (ListType            ty) xs = identsType ty xs
identsType (ArrowType      ty1 ty2) xs = identsType ty1 (identsType ty2 xs)
197
identsType (ParenType           ty) xs = identsType ty xs
198 199 200 201 202 203 204 205 206

-- After the interface declarations have been computed, the compiler
-- eventually must add hidden (data) type declarations to the interface
-- for all those types 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.

hiddenTypeDecl :: ModuleIdent -> TCEnv -> QualIdent -> IDecl
hiddenTypeDecl m tcEnv tc = case qualLookupTC (qualQualify m tc) tcEnv of
207 208 209
  [DataType     _ n _] -> hidingDataDecl tc n
  [RenamingType _ n _] -> hidingDataDecl tc n
  _                    -> internalError "Exports.hiddenTypeDecl"
210
  where hidingDataDecl tc1 n = HidingDataDecl NoPos tc1 $ take n identSupply
211

212 213
hiddenTypes :: ModuleIdent -> [IDecl] -> [QualIdent]
hiddenTypes m ds = [tc | tc <- Set.toList tcs, hidden tc]
214 215
  where tcs = foldr Set.delete (Set.fromList $ usedTypes ds)
                    (definedTypes ds)
216
        hidden tc = not (isQualified tc) || qidModule tc /= Just m
217 218 219 220 221

usedTypes :: [IDecl] -> [QualIdent]
usedTypes ds = foldr usedTypesDecl [] ds

usedTypesDecl :: IDecl -> [QualIdent] -> [QualIdent]
222 223 224 225 226 227
usedTypesDecl (IDataDecl     _ _ _ cs _) tcs =
  foldr usedTypesConstrDecl tcs cs
usedTypesDecl (INewtypeDecl  _ _ _ nc _) tcs = usedTypesNewConstrDecl nc tcs
usedTypesDecl (ITypeDecl     _ _ _ ty  ) tcs = usedTypesType ty tcs
usedTypesDecl (IFunctionDecl _ _ _ ty  ) tcs = usedTypesType ty tcs
usedTypesDecl _                          _   = internalError
228 229 230 231 232 233 234
  "Exports.usedTypesDecl: no pattern match" -- TODO

usedTypesConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
usedTypesConstrDecl (ConstrDecl    _ _ _ tys) tcs =
  foldr usedTypesType tcs tys
usedTypesConstrDecl (ConOpDecl _ _ ty1 _ ty2) tcs =
  usedTypesType ty1 (usedTypesType ty2 tcs)
235 236 237 238
usedTypesConstrDecl (RecordDecl     _ _ _ fs) tcs =
  foldr usedTypesFieldDecl tcs fs

usedTypesFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
239
usedTypesFieldDecl (FieldDecl _ _ ty) tcs = usedTypesType ty tcs
240 241

usedTypesNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
242 243
usedTypesNewConstrDecl (NewConstrDecl     _ _ _ ty) tcs = usedTypesType ty tcs
usedTypesNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) tcs = usedTypesType ty tcs
244 245

usedTypesType :: TypeExpr -> [QualIdent] -> [QualIdent]
246
usedTypesType (ConstructorType tc tys) tcs = tc : foldr usedTypesType tcs tys
247 248 249
usedTypesType (VariableType         _) tcs = tcs
usedTypesType (TupleType          tys) tcs = foldr usedTypesType tcs tys
usedTypesType (ListType            ty) tcs = usedTypesType ty tcs
250
usedTypesType (ArrowType      ty1 ty2) tcs =
251
  usedTypesType ty1 (usedTypesType ty2 tcs)
252
usedTypesType (ParenType           ty) tcs = usedTypesType ty tcs
253 254 255

definedTypes :: [IDecl] -> [QualIdent]
definedTypes ds = foldr definedType [] ds
256 257
  where
  definedType :: IDecl -> [QualIdent] -> [QualIdent]
258 259 260 261
  definedType (IDataDecl    _ tc _ _ _) tcs = tc : tcs
  definedType (INewtypeDecl _ tc _ _ _) tcs = tc : tcs
  definedType (ITypeDecl    _ tc _ _  ) tcs = tc : tcs
  definedType _                         tcs = tcs