Exports.hs 10.2 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
{- |
    Module      :  $Header$
    Description :  Cumputation of export interface
    Copyright   :  (c) 2000-2004, Wolfgang Lux
                       2005, Martin Engelke (men@informatik.uni-kiel.de)
                       2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
    License     :  OtherLicense

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

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

20 21
import Data.Maybe (isNothing, catMaybes)
import qualified Data.Set as Set (delete, fromList, toList)
22 23 24 25 26 27 28 29 30

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
31
import Env.OpPrec          (PEnv, PrecInfo (..), OpPrec (..), qualLookupP)
32
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
Björn Peemöller 's avatar
Björn Peemöller committed
33
import Env.Value           (ValueEnv, ValueInfo (..), qualLookupValue)
34 35 36

import CompilerEnv

37 38 39
-- ---------------------------------------------------------------------------
-- Computation of the interface
-- ---------------------------------------------------------------------------
40 41 42 43 44 45 46 47

-- 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.
48
--
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
-- 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)

exportInterface' :: Module -> PEnv -> TCEnv -> ValueEnv -> Interface
exportInterface' (Module m (Just (Exporting _ es)) _ _) pEnv tcEnv tyEnv
  = Interface m imports $ precs ++ hidden ++ decls
  where
  imports = map   (IImportDecl NoPos) $ usedModules decls
  precs   = foldr (infixDecl m pEnv) [] es
  hidden  = map   (hiddenTypeDecl m tcEnv) $ hiddenTypes decls
  decls   = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es
exportInterface' (Module _ Nothing _ _) _ _ _
  = internalError "Exports.exportInterface: no export specification"

infixDecl :: ModuleIdent -> PEnv -> Export -> [IDecl] -> [IDecl]
infixDecl m pEnv (Export             f) ds = iInfixDecl m pEnv f ds
infixDecl m pEnv (ExportTypeWith tc cs) ds =
71
  foldr (iInfixDecl m pEnv . qualifyLike (qidModule tc)) ds cs
72
  where qualifyLike = maybe qualify qualifyWith
73
infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match"
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99

iInfixDecl :: ModuleIdent -> PEnv -> QualIdent -> [IDecl] -> [IDecl]
iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
  []                           -> ds
  [PrecInfo _ (OpPrec fix pr)] ->
    IInfixDecl NoPos fix pr (qualUnqualify m op) : ds
  _                            -> internalError "Exports.infixDecl"

typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
typeDecl _ _     (Export             _) ds = ds
typeDecl m tcEnv (ExportTypeWith tc cs) ds = case qualLookupTC tc tcEnv of
  [DataType tc' n cs'] ->
    iTypeDecl IDataDecl m tc' n
       (constrDecls m (drop n identSupply) cs cs') : ds
  [RenamingType tc' n (DataConstr c n' [ty])]
    | c `elem` cs ->
        iTypeDecl INewtypeDecl m tc' n (NewConstrDecl NoPos tvs c ty') : ds
    | otherwise -> iTypeDecl IDataDecl m tc' n [] : ds
    where tvs = take n' (drop n identSupply)
          ty' = fromQualType m ty
  [AliasType tc' n ty] -> case ty of
    TypeRecord fs _ ->
        let ty' = TypeRecord (filter (\ (l,_) -> elem l cs) fs) Nothing
        in  iTypeDecl ITypeDecl m tc' n (fromQualType m ty') : ds
    _ -> iTypeDecl ITypeDecl m tc' n (fromQualType m ty) : ds
  _ -> internalError "Exports.typeDecl"
100
typeDecl _ _ _ _ = internalError "Exports.typeDecl: no pattern match"
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136

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

constrDecls :: ModuleIdent -> [Ident] -> [Ident] -> [Maybe DataConstr]
            -> [Maybe ConstrDecl]
constrDecls m tvs cs = clean . map (>>= constrDecl m tvs)
  where clean = reverse . dropWhile isNothing . reverse
        constrDecl m' tvs' (DataConstr c n tys)
          | c `elem` cs =
              Just (iConstrDecl (take n tvs') c (map (fromQualType m') tys))
          | otherwise = Nothing

iConstrDecl :: [Ident] -> Ident -> [TypeExpr] -> ConstrDecl
iConstrDecl tvs op [ty1,ty2]
  | isInfixOp op = ConOpDecl NoPos tvs ty1 op ty2
iConstrDecl tvs c tys = ConstrDecl NoPos tvs c tys

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
137
--
138 139 140 141 142
-- @
-- module A where { data A = A; }
-- module B(A(..)) where { import A; }
-- module C where { import B; x = A; }
-- @
143
--
144 145 146
-- the interface for module @C@ will import module @A@ but not module @B@.

usedModules :: [IDecl] -> [ModuleIdent]
147
usedModules ds = nub' (catMaybes (map qidModule (foldr identsDecl [] ds)))
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
  where nub' = Set.toList . Set.fromList

identsDecl :: IDecl -> [QualIdent] -> [QualIdent]
identsDecl (IDataDecl    _ tc _ cs) xs =
  tc : foldr identsConstrDecl xs (catMaybes 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
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)

identsNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
identsNewConstrDecl (NewConstrDecl _ _ _ ty) xs = identsType ty xs

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)
identsType (RecordType      fs rty) xs =
  foldr identsType (maybe xs (\ty -> identsType ty xs) rty) (map snd fs)

-- 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
  [DataType     _ n _] -> hidingDataDecl tc n
  [RenamingType _ n _] -> hidingDataDecl tc n
  _                    -> internalError "Exports.hiddenTypeDecl"
  where hidingDataDecl tc1 n = HidingDataDecl NoPos (unqualify tc1)
                             $ take n identSupply

hiddenTypes :: [IDecl] -> [QualIdent]
hiddenTypes ds = [tc | tc <- Set.toList tcs, not (isQualified tc)]
  where tcs = foldr Set.delete (Set.fromList $ usedTypes ds)
                    (definedTypes ds)

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

usedTypesDecl :: IDecl -> [QualIdent] -> [QualIdent]
usedTypesDecl (IDataDecl     _ _ _ cs) tcs =
  foldr usedTypesConstrDecl tcs (catMaybes cs)
usedTypesDecl (INewtypeDecl  _ _ _ nc) tcs = usedTypesNewConstrDecl nc tcs
usedTypesDecl (ITypeDecl     _ _ _ ty) tcs = usedTypesType ty tcs
usedTypesDecl (IFunctionDecl _ _ _ ty) tcs = usedTypesType ty tcs
usedTypesDecl _                        _   = internalError
  "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)

usedTypesNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
usedTypesNewConstrDecl (NewConstrDecl _ _ _ ty) tcs = usedTypesType ty tcs

usedTypesType :: TypeExpr -> [QualIdent] -> [QualIdent]
216
usedTypesType (ConstructorType tc tys) tcs = tc : foldr usedTypesType tcs tys
217 218 219
usedTypesType (VariableType         _) tcs = tcs
usedTypesType (TupleType          tys) tcs = foldr usedTypesType tcs tys
usedTypesType (ListType            ty) tcs = usedTypesType ty tcs
220
usedTypesType (ArrowType      ty1 ty2) tcs =
221
  usedTypesType ty1 (usedTypesType ty2 tcs)
222
usedTypesType (RecordType      fs rty) tcs = foldr usedTypesType
223
  (maybe tcs (\ty -> usedTypesType ty tcs) rty) (map snd fs)
224 225 226

definedTypes :: [IDecl] -> [QualIdent]
definedTypes ds = foldr definedType [] ds
227 228 229 230 231 232
  where
  definedType :: IDecl -> [QualIdent] -> [QualIdent]
  definedType (IDataDecl    _ tc _ _) tcs = tc : tcs
  definedType (INewtypeDecl _ tc _ _) tcs = tc : tcs
  definedType (ITypeDecl    _ tc _ _) tcs = tc : tcs
  definedType _                       tcs = tcs