module Exports (exportInterface) where
import Data.List (nub)
import Data.Maybe (catMaybes)
import qualified Data.Set as Set (delete, fromList, toList)
import Curry.Base.Position
import Curry.Base.Ident
import Curry.Syntax
import Base.CurryTypes (fromQualType)
import Base.Messages
import Base.Types
import Env.OpPrec (OpPrecEnv, PrecInfo (..), OpPrec (..), qualLookupP)
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import CompilerEnv
exportInterface :: CompilerEnv -> Module -> Interface
exportInterface env mdl = exportInterface' mdl
(opPrecEnv env) (tyConsEnv env) (valueEnv env)
exportInterface' :: Module -> OpPrecEnv -> 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 m decls
decls = foldr (typeDecl m tcEnv) (foldr (funDecl m tyEnv) [] es) es
exportInterface' (Module _ _ Nothing _ _) _ _ _
= internalError "Exports.exportInterface: no export specification"
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"
typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
typeDecl _ _ (Export _) ds = ds
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)
cs' = map (constrDecl m (drop n identSupply)) cs
ls = nub (concatMap recordLabels cs')
csIds = map constrIdent cs
[RenamingType tc' n c]
| null xs -> iTypeDecl IDataDecl m tc' n [] [] : ds
| otherwise -> iTypeDecl INewtypeDecl m tc' n nc hs : ds
where hs = filter (`notElem` xs) (cId : ls)
nc = newConstrDecl m (drop n identSupply) c
ls = nrecordLabels nc
cId = constrIdent c
[AliasType tc' n ty] -> ITypeDecl NoPos tc'' tvs ty' : ds
where tc'' = qualUnqualify m tc'
tvs = take n identSupply
ty' = fromQualType m ty
_ -> internalError "Exports.typeDecl"
typeDecl _ _ _ _ = internalError "Exports.typeDecl: no pattern match"
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
constrDecl :: ModuleIdent -> [Ident] -> DataConstr -> ConstrDecl
constrDecl m tvs (DataConstr c n [ty1,ty2])
| isInfixOp c
= ConOpDecl NoPos (take n tvs) (fromQualType m ty1) c (fromQualType m ty2)
constrDecl m tvs (DataConstr c n tys)
= ConstrDecl NoPos (take n tvs) c (map (fromQualType m) tys)
constrDecl m tvs (RecordConstr c n ls tys)
= RecordDecl NoPos (take n tvs) c
$ zipWith (FieldDecl NoPos . return) ls (map (fromQualType m) tys)
newConstrDecl :: ModuleIdent -> [Ident] -> DataConstr -> NewConstrDecl
newConstrDecl m tvs (DataConstr c n tys)
= NewConstrDecl NoPos (take n tvs) c (fromQualType m (head tys))
newConstrDecl m tvs (RecordConstr c n ls tys)
= NewRecordDecl NoPos (take n tvs) c (head ls, fromQualType m (head 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"
usedModules :: [IDecl] -> [ModuleIdent]
usedModules ds = nub' (catMaybes (map qidModule (foldr idsDecl [] ds)))
where nub' = Set.toList . Set.fromList
idsDecl :: IDecl -> [QualIdent] -> [QualIdent]
idsDecl (IDataDecl _ tc _ cs _) xs = tc : foldr idsConstrDecl xs cs
idsDecl (INewtypeDecl _ tc _ nc _) xs = tc : identsNewConstrDecl nc xs
idsDecl (ITypeDecl _ tc _ ty) xs = tc : idsType ty xs
idsDecl (IFunctionDecl _ f _ ty) xs = f : idsType ty xs
idsDecl _ _ = internalError "Exports.idsDecl: no pattern match"
idsConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
idsConstrDecl (ConstrDecl _ _ _ tys) xs = foldr idsType xs tys
idsConstrDecl (ConOpDecl _ _ ty1 _ ty2) xs = idsType ty1 (idsType ty2 xs)
idsConstrDecl (RecordDecl _ _ _ fs) xs = foldr identsFieldDecl xs fs
identsFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
identsFieldDecl (FieldDecl _ _ ty) xs = idsType ty xs
identsNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
identsNewConstrDecl (NewConstrDecl _ _ _ ty) xs = idsType ty xs
identsNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) xs = idsType ty xs
idsType :: TypeExpr -> [QualIdent] -> [QualIdent]
idsType (ConstructorType tc tys) xs = tc : foldr idsType xs tys
idsType (VariableType _) xs = xs
idsType (TupleType tys) xs = foldr idsType xs tys
idsType (ListType ty) xs = idsType ty xs
idsType (ArrowType ty1 ty2) xs = idsType ty1 (idsType ty2 xs)
idsType (ParenType ty) xs = idsType ty xs
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 tc1 $ take n identSupply
hiddenTypes :: ModuleIdent -> [IDecl] -> [QualIdent]
hiddenTypes m ds = [tc | tc <- Set.toList tcs, hidden tc]
where
tcs = foldr Set.delete (Set.fromList $ usedTypes ds) (definedTypes ds)
hidden tc = not (isQualified tc) || qidModule tc /= Just m
usedTypes :: [IDecl] -> [QualIdent]
usedTypes ds = foldr utDecl [] ds
utDecl :: IDecl -> [QualIdent] -> [QualIdent]
utDecl (IDataDecl _ _ _ cs _) tcs = foldr utConstrDecl tcs cs
utDecl (INewtypeDecl _ _ _ nc _) tcs = utNewConstrDecl nc tcs
utDecl (ITypeDecl _ _ _ ty ) tcs = utType ty tcs
utDecl (IFunctionDecl _ _ _ ty ) tcs = utType ty tcs
utDecl d _ = internalError
$ "Exports.utDecl: " ++ show d
utConstrDecl :: ConstrDecl -> [QualIdent] -> [QualIdent]
utConstrDecl (ConstrDecl _ _ _ tys) tcs = foldr utType tcs tys
utConstrDecl (ConOpDecl _ _ ty1 _ ty2) tcs = utType ty1 (utType ty2 tcs)
utConstrDecl (RecordDecl _ _ _ fs) tcs = foldr utFieldDecl tcs fs
utFieldDecl :: FieldDecl -> [QualIdent] -> [QualIdent]
utFieldDecl (FieldDecl _ _ ty) tcs = utType ty tcs
utNewConstrDecl :: NewConstrDecl -> [QualIdent] -> [QualIdent]
utNewConstrDecl (NewConstrDecl _ _ _ ty) tcs = utType ty tcs
utNewConstrDecl (NewRecordDecl _ _ _ (_,ty)) tcs = utType ty tcs
utType :: TypeExpr -> [QualIdent] -> [QualIdent]
utType (ConstructorType tc tys) tcs = tc : foldr utType tcs tys
utType (VariableType _) tcs = tcs
utType (TupleType tys) tcs = foldr utType tcs tys
utType (ListType ty) tcs = utType ty tcs
utType (ArrowType ty1 ty2) tcs = utType ty1 (utType ty2 tcs)
utType (ParenType ty) tcs = utType ty tcs
definedTypes :: [IDecl] -> [QualIdent]
definedTypes ds = foldr definedType [] ds
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