81d182b21020b815887e9057959228546cf61b6bChristian MaederDescription : pretty printing signatures
a39175891082dc8a598e5630e5558cb08b84ac0aChristian MaederCopyright : (c) Christian Maeder, Uni Bremen, DFKI GmbH 2002-2009
98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu ProdescuLicense : GPLv2 or higher, see LICENSE.txt
3f69b6948966979163bdfe8331c38833d5d90ecdChristian MaederMaintainer : Christian.Maeder@dfki.de
66267bcb678a9c341272c323b299337bcfdb7cc5Christian MaederStability : experimental
ffd01020a4f35f434b912844ad6e0d6918fadffdChristian MaederPortability : portable
66267bcb678a9c341272c323b299337bcfdb7cc5Christian Maederpretty printing a HasCASL environment
5553cf7e344c2b385a72e1244b419e9986042b8eChristian Maeder , diffClassMap
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder , mergeClassInfo
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder , mergeClassMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder , addClassMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder , minimizeClassMap
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder , improveDiag
5553cf7e344c2b385a72e1244b419e9986042b8eChristian Maeder , diffTypeMap
ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport qualified Data.Map as Map
ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport qualified Data.Set as Set
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty ClassInfo where
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder pretty (ClassInfo rk ks) = less <+>
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder if Set.null ks then pretty (rawToKind rk) else
e7ce154edb906685b3fa7f6c0a764e18a4658068Christian MaederprintGenKind :: GenKind -> Doc
e7ce154edb906685b3fa7f6c0a764e18a4658068Christian MaederprintGenKind k = case k of
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder Loose -> empty
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder Free -> text freeS
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder Generated -> text generatedS
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty TypeDefn where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder pretty td = case td of
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder NoTypeDefn -> empty
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder PreDatatype -> text "%(data type)%"
27912d626bf179b82fcb337077e5cd9653bb71cfChristian Maeder AliasTypeDefn s -> text assignS <+> pretty s
e13ee09381f136f5eadaabdb9699773c0052cf3dChristian Maeder DatatypeDefn dd -> text "%[" <> pretty dd <> text "]%"
5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian MaederprintAltDefn :: AltDefn -> Doc
5c933f3c61d2cfa7e76e4eb610a4b0bac988be47Christian MaederprintAltDefn (Construct mi ts p sels) = case mi of
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder Just i -> pretty i <+> fsep (map (parens . semiDs) sels) <> pretty p
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder Nothing -> text (typeS ++ sS) <+> ppWithCommas ts
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty Selector where
f6fc70956d64365527d77a521a96f54a1cc18f91Christian Maeder pretty (Select mi t p) = let d = pretty t in case mi of
51c65d5fb2d720dc77bc5cca15640cfa09711986Christian Maeder Just i -> pretty i <+> case p of
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder Partial -> text colonQuMark
51c65d5fb2d720dc77bc5cca15640cfa09711986Christian Maeder <+> if isSimpleType t then d else parens d
51c65d5fb2d720dc77bc5cca15640cfa09711986Christian Maeder Total -> colon
51c65d5fb2d720dc77bc5cca15640cfa09711986Christian Maeder <+> if isPrefixOf "?" $ show d then parens d else d
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty TypeInfo where
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder pretty (TypeInfo _ _ _ def) = pretty def
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty TypeVarDefn where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder pretty (TypeVarDefn v vk _ i) =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder printVarKind v vk <+> text ("%(var_" ++ shows i ")%")
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty VarDefn where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder pretty (VarDefn ty) =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder colon <+> pretty ty
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty ConstrInfo where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder pretty (ConstrInfo i t) =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder pretty i <+> colon <+> pretty t
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty OpDefn where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder pretty od = case od of
678e45c045799ce271c4719123ecd9cf4f456d4bChristian Maeder NoOpDefn _ -> empty
998747cb2ee575cccdd7d865c95d0ef07516a6a5Christian Maeder ConstructData _ -> text "%(constructor)%"
07e579405f31fff7f9315685661b5a87cb99c41bChristian Maeder SelectData cs _ -> sep
07e579405f31fff7f9315685661b5a87cb99c41bChristian Maeder [ text "%(selector of constructor(s)"
07e579405f31fff7f9315685661b5a87cb99c41bChristian Maeder , printList0 (Set.toList cs) <> text ")%" ]
07e579405f31fff7f9315685661b5a87cb99c41bChristian Maeder Definition b t ->
678e45c045799ce271c4719123ecd9cf4f456d4bChristian Maeder sep [text $ "%[ " ++ if isPred b then "<=>" else "="
678e45c045799ce271c4719123ecd9cf4f456d4bChristian Maeder , pretty t <+> text "]%" ]
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian MaederisOpDefn :: OpBrand -> OpDefn -> Bool
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian MaederisOpDefn b od = case od of
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian Maeder NoOpDefn c -> c == b
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian Maeder Definition c _ -> c == b
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian MaederisPredOpDefn :: OpDefn -> Bool
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian MaederisPredOpDefn = isOpDefn Pred
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian MaederisFunOpDefn :: OpDefn -> Bool
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian MaederisFunOpDefn = isOpDefn Fun
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty OpInfo where
678e45c045799ce271c4719123ecd9cf4f456d4bChristian Maeder pretty o = let od = opDefn o in
678e45c045799ce271c4719123ecd9cf4f456d4bChristian Maeder sep [pretty $ (if isPredOpDefn od then unPredTypeScheme else id)
fb8645096eb70aa243c146abe31d4173cfbe6e1aChristian Maeder $ opType o, pretty od]
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty DataEntry where
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder pretty (DataEntry im j k args _ talts) = let
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder mapAlt (Construct mi tys p sels) = Construct mi
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder (map (mapType im) tys) p $ map (map mapSel) sels
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder mapSel (Select mi ty p) = Select mi (mapType im ty) p
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder alts = Set.map mapAlt talts
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder in printGenKind k <+> keyword typeS <+>
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder fsep [fcat $ pretty i : map (parens . pretty) args
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder , defn, cat $ punctuate (space <> bar <> space)
6b23467258cdc15e05f1845cd400d60ca6eba966Christian Maeder $ map printAltDefn $ Set.toList alts]
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty Sentence where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder pretty s = case s of
e13ee09381f136f5eadaabdb9699773c0052cf3dChristian Maeder Formula t -> (case t of
e13ee09381f136f5eadaabdb9699773c0052cf3dChristian Maeder QuantifiedTerm Universal (_ : _) _ _ -> id
e13ee09381f136f5eadaabdb9699773c0052cf3dChristian Maeder _ -> addBullet) $ pretty t
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder DatatypeSen ls -> vcat (map pretty ls)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ProgEqSen _ _ pe -> keyword programS <+> pretty pe
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederdelPreDefs :: Env -> Env
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederdelPreDefs e =
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder let cm = classMap e
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder tm = typeMap e
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ops = assumps e
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ocm = diffClassMap cm cpoMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder { classMap = ocm
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder , typeMap = diffTypeMap ocm tm bTypes
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder , assumps = foldr (Map.delete . fst) ops bList }
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedergetSuperClasses :: ClassMap -> [(Id, Kind)]
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedergetSuperClasses = concatMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ( \ (i, ci) -> map ( \ s -> (i, s))
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder . Set.toList $ Set.delete (rawToKind $ rawKind ci) $ classKinds ci)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedergetSuperTypes :: TypeMap -> [(Id, Id)]
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedergetSuperTypes = concatMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ( \ (i, ti) -> map ( \ s -> (i, s))
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder . Set.toList $ superTypes ti)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedergetTypeKinds :: TypeMap -> [(Id, Kind)]
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedergetTypeKinds = concatMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ( \ (i, ti) -> map ( \ k -> (i, k))
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder . Set.toList $ otherTypeKinds ti)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedergetTypeAliases :: TypeMap -> [(Id, Type)]
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedergetTypeAliases = foldr
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ( \ (i, td) -> case typeDefn td of
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder AliasTypeDefn ty -> ((i, ty) :)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty Env where
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder pretty env = let
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder d = delPreDefs env
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder cm = classMap d
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder tm = typeMap d
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder tvs = localTypeVars d
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder vs = localVars d
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder poMap = Map.map (Set.partition (isPredOpDefn . opDefn)) $ assumps d
678e45c045799ce271c4719123ecd9cf4f456d4bChristian Maeder pMap = Map.map fst poMap
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian Maeder aoMap = Map.map snd poMap
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian Maeder foMap = Map.map (Set.partition (isFunOpDefn . opDefn)) aoMap
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian Maeder fMap = Map.map fst foMap
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian Maeder oMap = Map.map snd foMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ltm = getTypeKinds tm
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder stm = getSuperTypes tm
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder atm = getTypeAliases tm
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder scm = getSuperClasses cm
31a189d4cff554f78407cdc422480e84e99a6ec6Christian Maeder bas = map (\ (b, o) -> Unparsed_anno (Annote_word "binder")
31a189d4cff554f78407cdc422480e84e99a6ec6Christian Maeder (Line_anno $ " " ++ show b ++ ", " ++ show o) $ posOfId b)
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder mkPlural s = s ++ if last s == 's' then "es" else "s"
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder header2 l s = keyword $ case l of
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder _ : _ : _ -> mkPlural s
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder header m s = keyword $
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder if Map.size m < 2 then s else mkPlural s
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder in noPrint (Map.null cm) (header cm classS)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder $+$ printMap0 (Map.map ( \ ci -> ci { classKinds = Set.empty }) cm)
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder $+$ noPrint (null scm) (header2 scm classS)
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder $+$ vcat (punctuate semi $ map ( \ (i, s) ->
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder pretty i <+> text lessS <+> pretty s) scm)
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder $+$ noPrint (null ltm) (header2 ltm typeS)
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder $+$ vcat (punctuate semi $ map ( \ (i, k) ->
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder pretty i <+> colon <+> pretty k) ltm)
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder $+$ noPrint (null stm) (header2 stm typeS)
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder $+$ vcat (punctuate semi $ map ( \ (i, s) ->
946f62de1b188898dde0c472f2a8a6fb86f4d2f5Christian Maeder pretty i <+> text lessS <+> pretty s) stm)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder $+$ noPrint (null atm) (header2 atm typeS)
a39175891082dc8a598e5630e5558cb08b84ac0aChristian Maeder $+$ printAliasTypes atm
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder $+$ noPrint (Map.null tvs) (header tvs varS)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder $+$ printMap0 tvs
31a189d4cff554f78407cdc422480e84e99a6ec6Christian Maeder $+$ vcat (map annoDoc bas)
678e45c045799ce271c4719123ecd9cf4f456d4bChristian Maeder $+$ printSetMap (keyword opS) space oMap
678e45c045799ce271c4719123ecd9cf4f456d4bChristian Maeder $+$ printSetMap (keyword predS) space pMap
6fe64923dcfd4b70bb863a56ad9ca2152faf8a0cChristian Maeder $+$ printSetMap (keyword functS) space fMap
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder $+$ noPrint (Map.null vs) (header vs varS)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder $+$ printMap0 vs
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder $+$ vcat (map (pretty . fromLabelledSen) . reverse $ sentences d)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder $+$ vcat (map pretty . reverse $ envDiags d)
34b55522ba6fe2601e4ee37a9ba1fc4b1a0bf50bChristian MaedermostSyms :: Env -> [Symbol]
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedermostSyms e = let
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder d = delPreDefs e
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder cm = classMap d
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder tm = typeMap d
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder in map (\ (i, k) -> idToClassSymbol i $ rawKind k) (Map.toList cm)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ++ map (\ (i, s) -> Symbol i $ SuperClassSymbol s) (getSuperClasses cm)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ++ map (\ (i, s) -> Symbol i $ TypeKindInstance s) (getTypeKinds tm)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ++ map (\ (i, s) -> Symbol i $ SuperTypeSymbol s) (getSuperTypes tm)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder ++ map (\ (i, s) -> Symbol i $ TypeAliasSymbol s) (getTypeAliases tm)
34b55522ba6fe2601e4ee37a9ba1fc4b1a0bf50bChristian Maeder ++ concatMap (\ (i, ts) ->
167b6ed8639bce096380defb7311ded501ebb5daChristian Maeder map (\ t -> (if isPredOpDefn $ opDefn t then
167b6ed8639bce096380defb7311ded501ebb5daChristian Maeder Symbol i . PredAsItemType . unPredTypeScheme
167b6ed8639bce096380defb7311ded501ebb5daChristian Maeder else idToOpSymbol i) $ opType t) $ Set.toList ts)
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederprintAliasType :: Type -> Doc
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederprintAliasType ty =
a39175891082dc8a598e5630e5558cb08b84ac0aChristian Maeder let (args, t) = getArgsAndType ty in
a39175891082dc8a598e5630e5558cb08b84ac0aChristian Maeder fsep $ map (parens . pretty) args ++ [text assignS, pretty t]
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederprintAliasTypes :: [(Id, Type)] -> Doc
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederprintAliasTypes = vcat . punctuate semi .
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder map (\ (i, ty) -> sep [pretty i, printAliasType ty])
a39175891082dc8a598e5630e5558cb08b84ac0aChristian MaedergetArgsAndType :: Type -> ([TypeArg], Type)
a39175891082dc8a598e5630e5558cb08b84ac0aChristian MaedergetArgsAndType ty = case ty of
a39175891082dc8a598e5630e5558cb08b84ac0aChristian Maeder TypeAbs arg t _ -> let (l, r) = getArgsAndType t in (arg : l, r)
a39175891082dc8a598e5630e5558cb08b84ac0aChristian Maeder _ -> ([], ty)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederprintMap0 :: (Pretty a, Ord a, Pretty b) => Map.Map a b -> Doc
a39175891082dc8a598e5630e5558cb08b84ac0aChristian MaederprintMap0 = printMap id (vcat . punctuate semi) $ \ a b -> fsep [a, b]
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederprintMap1 :: (Pretty a, Ord a, Pretty b) => Map.Map a b -> Doc
a39175891082dc8a598e5630e5558cb08b84ac0aChristian MaederprintMap1 = printMap id vcat $ \ a b -> fsep [a, mapsto, b]
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty Morphism where
2e9985cd67e4f2414becb670ef33b8f16513e41dChristian Maeder let tm = typeIdMap m
f9d358050e368eef1dcb45565b921a70bc68ef2dMihai Codescu cm = classIdMap m
2e9985cd67e4f2414becb670ef33b8f16513e41dChristian Maeder fm = funMap m
d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder {- the types in funs are already mapped
d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder key und value types only differ wrt. partiality -}
a74f814d3b445eadad6f68737a98a7a303698affChristian Maeder ds = Map.foldWithKey ( \ (i, _) (j, t) ->
72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maeder ((pretty i <+> mapsto <+>
72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maeder pretty j <+> colon <+> pretty t) :))
717686b54b9650402e2ebfbaadf433eab8ba5171Christian Maeder in (if Map.null tm then empty
405b95208385572f491e1e0207d8d14e31022fa6Christian Maeder else keyword (typeS ++ sS) <+> printMap1 tm)
f2ee9fc53048ea92bad79e3f5d292d83efd7f8beMihai Codescu $+$ (if Map.null cm then empty
f2ee9fc53048ea92bad79e3f5d292d83efd7f8beMihai Codescu else keyword (classS ++ sS) <+> printMap1 cm)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder $+$ (if Map.null fm then empty
8c81b727b788d90ff3b8cbda7b0900c9009243bbChristian Maeder else keyword (opS ++ sS) <+> sepByCommas ds)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder $+$ colon <+> specBraces (pretty $ msource m)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder <+> specBraces (pretty $ mtarget m)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty Symbol where
599766906b25938d5b184febd19b8e0bbe623e7bChristian Maeder pretty s = let ty = symType s in
599766906b25938d5b184febd19b8e0bbe623e7bChristian Maeder printSK (symbTypeToKind ty) [()] <+> pretty (symName s) <+> case ty of
599766906b25938d5b184febd19b8e0bbe623e7bChristian Maeder SuperTypeSymbol sty -> less <+> pretty sty
599766906b25938d5b184febd19b8e0bbe623e7bChristian Maeder SuperClassSymbol k -> less <+> pretty k
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder TypeAliasSymbol t -> printAliasType t
599766906b25938d5b184febd19b8e0bbe623e7bChristian Maeder TypeKindInstance k -> colon <+> pretty k
599766906b25938d5b184febd19b8e0bbe623e7bChristian Maeder OpAsItemType sc -> colon <+> pretty sc
599766906b25938d5b184febd19b8e0bbe623e7bChristian Maeder TypeAsItemType k -> colon <+> pretty (rawToKind k)
599766906b25938d5b184febd19b8e0bbe623e7bChristian Maeder ClassAsItemType k -> colon <+> pretty (rawToKind k)
167b6ed8639bce096380defb7311ded501ebb5daChristian Maeder PredAsItemType sc -> colon <+> pretty sc
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Pretty RawSymbol where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder pretty rs = case rs of
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder AnID i -> pretty i
d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder AKindedId k i -> printSK k [i] <+> pretty i
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ASymbol s -> pretty s
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian MaederimproveDiag :: (GetRange a, Pretty a) => a -> Diagnosis -> Diagnosis
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian MaederimproveDiag v d = d
d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder { diagString = let f : l = lines $ diagString d in
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder unlines $ (f ++ " of '" ++ showDoc v "'") : l
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder , diagPos = getRange v }
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian MaedermergeMap :: (Ord a, GetRange a, Pretty a) => (b -> b -> Result b)
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder -> Map.Map a b -> Map.Map a b -> Result (Map.Map a b)
72b9099aeec0762bae4546db3bc4b48721027bf4Christian MaedermergeMap f m1 = foldM ( \ m (k, v) -> case Map.lookup k m of
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder Nothing -> return $ Map.insert k v m
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder Just w -> let
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder Result ds r = do
72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maeder in Result (map (improveDiag k) ds) r) m1 . Map.toList
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian MaedermergeClassInfo :: ClassInfo -> ClassInfo -> Result ClassInfo
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian MaedermergeClassInfo c1 c2 = do
d4146229cf85928342dfd25ec8b579a7feb0d381Christian Maeder k <- minRawKind "class raw kind" (rawKind c1) $ rawKind c2
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder return $ ClassInfo k $ Set.union (classKinds c1) $ classKinds c2
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederminimizeClassMap :: ClassMap -> ClassMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederminimizeClassMap cm = Map.map (\ ci -> ci { classKinds =
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder keepMinKinds cm [classKinds ci] }) cm
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedermergeClassMap :: ClassMap -> ClassMap -> Result ClassMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaedermergeClassMap c = fmap minimizeClassMap . mergeMap mergeClassInfo c
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederaddClassMap :: ClassMap -> ClassMap -> ClassMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederaddClassMap c = fromMaybe (error "addClassMap") . maybeResult . mergeClassMap c
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederaddCpoMap :: ClassMap -> ClassMap
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian MaederaddCpoMap = addClassMap cpoMap
5553cf7e344c2b385a72e1244b419e9986042b8eChristian MaederdiffClassMap :: ClassMap -> ClassMap -> ClassMap
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian MaederdiffClassMap c1 c2 =
964d1dce6aa88a14e240a4f2fb81c539d2f834fcChristian Maeder let ce = addClassMap c1 c2
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder in Map.differenceWith (diffClass ce) c1 c2
5553cf7e344c2b385a72e1244b419e9986042b8eChristian Maeder-- | compute difference of class infos
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian MaederdiffClass :: ClassMap -> ClassInfo -> ClassInfo -> Maybe ClassInfo
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian MaederdiffClass cm (ClassInfo r1 k1) (ClassInfo _ k2) =
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder Set.filter (flip (lesserKind cm) k) k2) k1
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder in if Set.null ks then Nothing else
f42bcc750a9a02cb4f753b70679f9aacf1b338d7Christian Maeder Just $ ClassInfo r1 ks
59c301c268f79cfde0a4c30a2c572a368db98da5Christian MaederdiffTypeMap :: ClassMap -> TypeMap -> TypeMap -> TypeMap
167b6ed8639bce096380defb7311ded501ebb5daChristian MaederdiffTypeMap = Map.differenceWith . diffType
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder-- | compute difference of type infos
59c301c268f79cfde0a4c30a2c572a368db98da5Christian MaederdiffType :: ClassMap -> TypeInfo -> TypeInfo -> Maybe TypeInfo
59c301c268f79cfde0a4c30a2c572a368db98da5Christian MaederdiffType cm ti1 ti2 =
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder let k1 = otherTypeKinds ti1
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder k2 = otherTypeKinds ti2
0a320bc4cdbf38f480b75ac15a54db1c4885b497Christian Maeder Set.filter (flip (lesserKind cm) k) k2) k1
167b6ed8639bce096380defb7311ded501ebb5daChristian Maeder sups = Set.difference (superTypes ti1) $ superTypes ti2
167b6ed8639bce096380defb7311ded501ebb5daChristian Maeder in if Set.null ks && Set.null sups then Nothing else
59c301c268f79cfde0a4c30a2c572a368db98da5Christian Maeder Just $ ti1 { otherTypeKinds = ks
167b6ed8639bce096380defb7311ded501ebb5daChristian Maeder , superTypes = sups }