SubtypeDecl.hs revision 72f24c5e53e062d8da71f63b2724acd5015dbe65
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederModule : $Header$
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederDescription : analysis of subtype declarations
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederCopyright : (c) Christian Maeder and Uni Bremen 2005
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederMaintainer : Christian.Maeder@dfki.de
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederStability : provisional
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederPortability : portable
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maederanalyse subtype decls
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder ( addSuperType
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder , addAliasType
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maederimport qualified Data.Set as Set
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maederimport qualified Data.Map as Map
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederetaReduceAux :: ([TypeArg], [TypeArg], [Type])
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder -> ([TypeArg], [TypeArg], [Type])
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederetaReduceAux p = case p of
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder (ks, nA : rAs , tA : rArgs) | typeArgToType nA == tA ->
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder etaReduceAux (nA : ks, rAs, rArgs)
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederetaReduce :: Kind -> [TypeArg] -> Type -> Maybe (Kind, [TypeArg], Type)
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederetaReduce k nAs t =
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder let (topTy, tArgs) = getTypeAppl t
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder (ks, newAs, ts) = etaReduceAux ([], reverse nAs, reverse tArgs)
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder in case ks of
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder _ : _ -> Just (typeArgsListToKind ks k,
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder reverse newAs, mkTypeAppl topTy $ reverse ts)
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder [] -> Nothing
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder-- | add a supertype to a given type id
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederaddSuperType :: Type -> Kind -> (Id, [TypeArg]) -> State Env ()
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederaddSuperType t ak p@(i, nAs) = case t of
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder TypeName j _ v -> if v /= 0 then
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addDiags[mkDiag Error ("illegal type variable as supertype") j]
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder else addSuperId j ak i
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder _ -> case etaReduce ak nAs t of
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder Just (nk, rAs, rT) -> addSuperType rT nk (i, rAs)
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder Nothing -> case t of
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder TypeAppl (TypeName l _ _) tl | l == lazyTypeId ->
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder addSuperType tl ak p
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder TypeAppl t1 t2 -> case redStep t of
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder Just r -> addSuperType r ak p
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder Nothing -> do
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder j <- newTypeIdentifier i
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder let rk = rawKindOfType t1
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder k = rawToKind rk
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder vs = map (fst . snd) $ leaves (> 0) t1
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder newArgs = filter ( \ a -> getTypeVar a `elem` vs) nAs
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder jTy = TypeName j (typeArgsListToRawKind newArgs rk) 0
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder aTy = mkTypeAppl jTy $ map typeArgToType newArgs
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder if null vs then addTypeId True NoTypeDefn k j else return True
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addSuperType t1 k (j, newArgs)
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder tm <- gets typeMap
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addAliasType False i
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder (TypeScheme nAs (expandAlias tm $ TypeAppl aTy t2) nullRange)
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder $ typeArgsListToKind nAs ak
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder KindedType ty _ _ -> addSuperType ty ak p
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder ExpandedType t1 t2 -> do
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addSuperType t1 ak p
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addSuperType t2 ak p
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder _ -> error "addSuperType"
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder-- | generalize a type scheme for an alias type
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaedergeneralizeT :: TypeScheme -> State Env TypeScheme
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaedergeneralizeT sc@(TypeScheme args ty p) = do
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addDiags $ generalizable True sc
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder return $ TypeScheme (genTypeArgs args) (generalize args ty) p
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaedernewTypeIdentifier :: Id -> State Env Id
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaedernewTypeIdentifier i = do
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder n <- toEnvState inc
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder return $ simpleIdToId $ Token (genNamePrefix ++ "t" ++ show n) $ posOfId i
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder-- | add second identifier as super type of known first identifier
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederaddSuperId :: Id -> Kind -> Id -> State Env ()
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederaddSuperId j kind i = do
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder tm <- gets typeMap
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder cm <- gets classMap
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder if i == j then return () -- silently ignore
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder else case Map.lookup i tm of
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder Nothing -> return () -- previous error
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder Just (TypeInfo ok ks sups defn) -> if Set.member j sups
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder then addDiags[mkDiag Hint "repeated supertype" j]
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder else if Set.member i $ superIds tm j then do
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addDiags[mkDiag Warning
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder ("made '" ++ showId i "' an alias of") j]
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addAliasType False i (TypeScheme [] (TypeName j ok 0)
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder $ posOfId j) kind
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder else let Result _ (Just rk) = anaKindM kind cm in
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder maybe (addDiags $ diffKindDiag i ok rk)
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder (const $ putTypeMap $ Map.insert i
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder (TypeInfo ok ks (Set.insert j sups) defn) tm)
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder $ minRawKind "" ok rk
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder-- | add an alias type definition
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederaddAliasType :: Bool -> Id -> TypeScheme -> Kind -> State Env Bool
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederaddAliasType b i sc fullKind = do
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder newSc <- generalizeT sc
e90dc723887d541f809007ae81c9bb73ced9592eChristian Maeder addAliasTypeAux b i newSc fullKind
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederaddAliasTypeAux :: Bool -> Id -> TypeScheme -> Kind -> State Env Bool
e90dc723887d541f809007ae81c9bb73ced9592eChristian MaederaddAliasTypeAux b i (TypeScheme args ty ps) fullKind = do
4314e26a12954cb1c9be4dea10aa8103edac5bbbChristian Maeder addTypeId b (AliasTypeDefn $ foldr ( \ t y -> TypeAbs t y ps) ty args)