TypeRel.hs revision b87efd3db0d2dc41615ea28669faf80fc1b48d56
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederModule : $Header$
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederDescription : compute subtype dependencies
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederCopyright : (c) Christian Maeder and Uni Bremen 2003-2005
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederLicense : GPLv2 or higher
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederMaintainer : Christian.Maeder@dfki.de
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederStability : experimental
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederPortability : portable
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maedercompute subtype dependencies
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maederimport qualified Common.Lib.Rel as Rel
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maederimport qualified Data.Map as Map
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maederimport qualified Data.Set as Set
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedertypeRel :: TypeMap -> Rel.Rel Id
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedertypeRel = Rel.transReduce . Rel.irreflex . Rel.transClosure
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder Set.fold (Rel.insert i) r $ superTypes ti) Rel.empty
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedergetRawKind :: TypeMap -> Id -> RawKind
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedergetRawKind tm i = typeKind $
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder Map.findWithDefault (error $ showId i " not found in type map") i tm
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder-- | make a polymorphic function from a to b
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedermkInjOrProjType :: Arrow -> TypeScheme
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedermkInjOrProjType arr =
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder TypeScheme [aTypeArg, bTypeArg] (mkFunArrType aType arr bType) nullRange
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederinjType :: TypeScheme
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederinjType = mkInjOrProjType FunArr
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederprojType :: TypeScheme
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaederprojType = mkInjOrProjType PFunArr
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedermkInjOrProj :: Arrow -> Set.Set OpInfo
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedermkInjOrProj arr = Set.singleton OpInfo
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder { opType = mkInjOrProjType arr
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder , opDefn = NoOpDefn Fun }
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtRelName :: Id
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtRelName = mkId [genToken "subt"]
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtRelType :: TypeScheme
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtRelType = TypeScheme [aTypeArg, bTypeArg]
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder (mkFunArrType (mkProductType [aType, bType]) PFunArr unitType) nullRange
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtRel :: Set.Set OpInfo
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder { opType = subtRelType
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder , opDefn = NoOpDefn Fun }
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtAxioms :: TypeMap -> [Named Sentence]
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtAxioms tm =
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder let tr = typeRel tm in
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder if Rel.null tr then [] else subtReflex : subtTrans : subtInjProj : injTrans
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder : map (subtAx tm) (Rel.toList tr)
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maedernr = nullRange
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedergetKindAppl :: RawKind -> [Variance]
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedergetKindAppl rk = case rk of
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder ClassKind () -> []
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder FunKind v _ r _ -> v : getKindAppl r
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedermkTypeArg :: Id -> Int -> TypeArg
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedermkTypeArg i c = TypeArg i NonVar (VarKind universe) rStar c Other nr
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtAx :: TypeMap -> (Id, Id) -> Named Sentence
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian MaedersubtAx tm (i1, i2) = let
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder (Map.findWithDefault (error "TypeRel.subtAx") i bTypes) i tm
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder e1 = findType i1
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder e2 = findType i2
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder txt = shows i1 "_<_" ++ show i2
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder l1 = getKindAppl $ typeKind e1
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder l2 = getKindAppl $ typeKind e2
d5ef5a29a89fa5548f81fcd49fcf0ffda69d45b0Christian Maeder l3 = zipWith minVariance l1 l2
monos e = concatMap (makeMonos e) . Map.toList $ assumps e
makeMonos :: Env -> (Id, Set.Set OpInfo) -> [Named Sentence]
makeMonos e (i, s) = makeEquivMonos e i . map opType $ Set.toList s