HatAna.hs revision 88ece6e49930670e8fd3ee79c89a2e918d2fbd0c
4b0a4c7dea0f67a233dcc42ce9bb18d36de109aeChristian MaederModule : $Header$
10397bcc134edbcfbe3ae2c7ea4c6080036aae22Christian MaederCopyright : (c) Christian Maeder, Uni Bremen 2002-2004
97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
e7ce154edb906685b3fa7f6c0a764e18a4658068Christian MaederMaintainer : maeder@tzi.de
4b0a4c7dea0f67a233dcc42ce9bb18d36de109aeChristian MaederStability : provisional
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaederPortability : non-portable
23f2c59644866aa82e90de353e77f9f1d1b51b9aChristian Maedermodule Haskell.HatAna (module Haskell.HatAna, PNT, TiDecl) where
23f2c59644866aa82e90de353e77f9f1d1b51b9aChristian Maederimport Haskell.HatParser hiding (hatParser)
dc6b48bb46df8e56da3491c98476e6da0d1d5d1dChristian Maederimport qualified Common.Lib.Map as Map
fc8c6570c7b4ee13f375eb607bed2290438573bfChristian Maederimport qualified Common.Lib.Set as Set
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maederimport qualified Data.Set as DSet
af621d0066770895fd79562728e93099c8c52060Christian Maedertype Scope = Rel (SN HsName) (Ent (SN String))
e8ffec0fa3d3061061bdc16e44247b9cf96b050fChristian Maederdata Sign = Sign
79d11c2e3ad242ebb241f5d4a5e98a674c0b986fChristian Maeder { instances :: [Instance PNT]
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder , types :: Map.Map (HsIdentI PNT) (Kind, TypeInfo PNT)
f8f78a2c8796a387a4348cc672ae08e8d9f69315Christian Maeder , values :: Map.Map (HsIdentI PNT) (Scheme PNT)
024621f43239cfe9629e35d35a8669fad7acbba2Christian Maeder , scope :: Scope
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder , fixities :: Map.Map (HsIdentI (SN String)) HsFixity
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder } deriving (Show, Eq)
afa6848d579d235c9677e1ab477916df8e5ae11aChristian MaederdiffSign :: Sign -> Sign -> Sign
afa6848d579d235c9677e1ab477916df8e5ae11aChristian MaederdiffSign e1 e2 = emptySign
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder { instances = instances e1 \\ instances e2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder , types = types e1 `Map.difference` types e2
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder , values = values e1 `Map.difference` values e2
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder , scope = scope e1 `minusRel` scope e2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder , fixities = fixities e1 `Map.difference` fixities e2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian MaederaddSign :: Sign -> Sign -> Sign
afa6848d579d235c9677e1ab477916df8e5ae11aChristian MaederaddSign e1 e2 = emptySign
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder { instances = let is = instances e2 in (instances e1 \\ is) ++ is
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder , types = types e1 `Map.union` types e2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder , values = values e1 `Map.union` values e2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder , scope = scope e1 `DSet.union` scope e2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder , fixities = fixities e1 `Map.union` fixities e2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian MaederisSubSign :: Sign -> Sign -> Bool
afa6848d579d235c9677e1ab477916df8e5ae11aChristian MaederisSubSign e1 e2 = diffSign e1 e2 == emptySign
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maederinstance Eq (TypeInfo i) where
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder _ == _ = True
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maederinstance Eq (TiDecl PNT) where
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder s1 == s2 = show s1 == show s2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maederinstance Ord (TiDecl PNT) where
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder s1 <= s2 = show s1 <= show s2
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maederinstance PrettyPrint (TiDecl PNT) where
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maeder printText0 _ = text . pp
afa6848d579d235c9677e1ab477916df8e5ae11aChristian Maederinstance PrettyPrint Sign where
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder printText0 _ Sign { instances = is, types = ts,
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder values = vs, fixities = fs, scope = sc }
e7ce154edb906685b3fa7f6c0a764e18a4658068Christian Maeder = text "{-" $$ (if null is then empty else
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder text "instances:" $$
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder vcat (map (text . pp) is)) $$
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder (if Map.null ts then empty else
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder text "\ntypes:" $$
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder vcat (map (text . pp)
986e0e9cf8c2358f455460b3fc75ce7c5dcf0973Christian Maeder [ a :>: b | (a, b) <- Map.toList ts ])) $$
6a7e00a968cb0f3f9ccae19ab47ef3636c7e79bfChristian Maeder (if Map.null vs then empty else
6a7e00a968cb0f3f9ccae19ab47ef3636c7e79bfChristian Maeder text "\nvalues:" $$
88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian Maeder vcat (map (text . pp)
88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian Maeder [ a :>: b | (a, b) <- Map.toList vs ])) $$
88ece6e49930670e8fd3ee79c89a2e918d2fbd0cChristian Maeder (if Map.null fs then empty else
6a7e00a968cb0f3f9ccae19ab47ef3636c7e79bfChristian Maeder text "\nfixities:" $$
6a7e00a968cb0f3f9ccae19ab47ef3636c7e79bfChristian Maeder vcat [ text (pp b) <+> text (pp a)
6a7e00a968cb0f3f9ccae19ab47ef3636c7e79bfChristian Maeder | (a, b) <- Map.toList fs ]) $$
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder text "\nscope:" $$
6a7e00a968cb0f3f9ccae19ab47ef3636c7e79bfChristian Maeder text (pp sc) $$
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder text "module Dummy where"
6a7e00a968cb0f3f9ccae19ab47ef3636c7e79bfChristian Maeder $$ text "import MyLogic"
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaederextendSign :: Sign -> [Instance PNT]
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder -> [TAssump PNT]
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder -> [Assump PNT]
89054b2b95a3f92e78324dc852f3d34704e2ca49Christian Maeder -> [(HsIdentI (SN String), HsFixity)]
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaederextendSign e is ts vs s fs = addSign e emptySign
b9eb4099ac3fd619c73f48cd022fc0f3c9b732f0Christian Maeder { instances = is
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder , types = Map.fromList [ (a, b) | (a :>: b) <- ts ]
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder , values = Map.fromList [ (a, b) | (a :>: b) <- vs ]
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder , fixities = Map.fromList fs
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian MaederemptySign :: Sign
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian MaederemptySign = Sign
af621d0066770895fd79562728e93099c8c52060Christian Maeder { instances = []
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder , scope = emptyRel
f353be6210f67ffd4a46967bba749afc968cee52Christian MaederhatAna :: (HsDecls, Sign, GlobalAnnos) ->
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder Result (HsDecls, Sign, Sign, [Named (TiDecl PNT)])
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaederhatAna (HsDecls hs, e, ga) = do
05e2a3161e4589a717c6fe5c7306820273a473c5Christian Maeder let (rs, ds) = preludeConflicts hs
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder Result ds $ Just ()
05e2a3161e4589a717c6fe5c7306820273a473c5Christian Maeder (decls, diffSig, accSig, sens) <-
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder hatAna2 (HsDecls rs, addSign e preludeSign, ga)
8485da94b57d8b5135ee685b55c982b037ed4140Christian Maeder return (decls, diffSig, diffSign accSig preludeSign, sens)
8485da94b57d8b5135ee685b55c982b037ed4140Christian MaederpreludeSign :: Sign
e76e6a43f51438215737d6fc176c89da05bb86daChristian MaederpreludeSign = case maybeResult $ hatAna2
8485da94b57d8b5135ee685b55c982b037ed4140Christian Maeder (HsDecls $ preludeDecls,
8485da94b57d8b5135ee685b55c982b037ed4140Christian Maeder emptySign, emptyGlobalAnnos) of
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder Just (_, _, sig, _) -> sig
8485da94b57d8b5135ee685b55c982b037ed4140Christian Maeder _ -> error "preludeSign"
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian MaederhatAna2 :: (HsDecls, Sign, GlobalAnnos) ->
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder Result (HsDecls, Sign, Sign, [Named (TiDecl PNT)])
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaederhatAna2 (hs@(HsDecls ds), e, _) = do
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder let parsedMod = HsModule loc0 (SN mod_Prelude loc0) Nothing [] ds
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder astMod = toMod parsedMod
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder insc = inscope astMod (const emptyRel)
a94b530fa82bb281caac766a9c0f7b2fcfe7a584Christian Maeder osc = scope e `DSet.union` insc
997c56f3bc74a703043010978e5013fdb074d659Christian Maeder expScope :: Rel (SN String) (Ent (SN String))
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder expScope = mapDom (fmap hsUnQual) osc
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian Maeder wm :: WorkModuleI QName (SN String)
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder wm = mkWM (osc, expScope)
8485da94b57d8b5135ee685b55c982b037ed4140Christian Maeder fixs = mapFst getQualified $ getInfixes parsedMod
8485da94b57d8b5135ee685b55c982b037ed4140Christian Maeder fixMap = Map.fromList fixs `Map.union` fixities e
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder rm = reAssocModule wm [(mod_Prelude, Map.toList fixMap)] parsedMod
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder (HsModule _ _ _ _ sds, _) =
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder scopeModule (wm, [(mod_Prelude, expScope)]) rm
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder ent2pnt (Ent m (HsCon i) t) =
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder HsCon (topName Nothing m (bn i) (origt m t))
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder ent2pnt (Ent m (HsVar i) t) =
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder HsVar (topName Nothing m (bn i) (origt m t))
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder bn i = getBaseName i
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder origt m = fmap (osub m)
8485da94b57d8b5135ee685b55c982b037ed4140Christian Maeder osub m n = origName n m n
dc6b48bb46df8e56da3491c98476e6da0d1d5d1dChristian Maeder findPredef ns (_, n) =
53301de22afd7190981b363b57c48df86fcb50f7Christian Maeder case filter ((==ns) . namespace) $ applyRel expScope (fakeSN n) of
4b0a4c7dea0f67a233dcc42ce9bb18d36de109aeChristian Maeder [v] -> Right (ent2pnt v)
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder _ -> Left ("'" ++ n ++ "' unknown or ambiguous")
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian Maeder inMyEnv = withStdNames findPredef
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian Maeder . inModule (const mod_Prelude) []
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder . extendts [ a :>: b | (a, b) <- Map.toList $ values e ]
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian Maeder . extendkts [ a :>: b | (a, b) <- Map.toList $ types e ]
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian Maeder . extendIEnv (instances e)
fe5dbb45b6a8abf34375b4bc5f2a81cda664c0e4Christian Maeder [] -> return ()
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian Maeder d : _ -> Result [Diag Hint ("\n" ++ pp sds)
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder [formSrcLoc $ srcLoc d]] $ Just ()
fcec1ffa4a95dbc47cf23f75e6843ceff93a925eChristian Maeder fs :>: (is, (ts, vs)) <-
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian Maeder lift $ inMyEnv $ tcTopDecls id sds
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder let accSign = extendSign e is ts vs insc fixs
836e72a3c413366ba9801726f3b249c7791cb9caChristian Maeder return (hs, diffSign accSign e, accSign, map emptyName $ fromDefs
62ecb1e7f8fd9573eea8369657de12c7bf9f4f25Christian Maeder (fs :: TiDecls PNT))
c1031ac42b3f3d7d0fe7d9d6b54423a092d473a0Christian Maeder-- filtering some Prelude stuff
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaederformSrcLoc :: SrcLoc -> Pos
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian MaederformSrcLoc (SrcLoc file _ line col) = SourcePos file line col
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaedergetHsDecl :: (Rec a b, GetBaseStruct b (DI i e p ds t [t] t)) =>
23f8d286586ff38a9e73052b2c7c04c62c5c638fChristian Maeder a -> DI i e p ds t [t] t
23f8d286586ff38a9e73052b2c7c04c62c5c638fChristian MaedergetHsDecl = maybe (HsFunBind loc0 []) id . basestruct . struct
fe5dbb45b6a8abf34375b4bc5f2a81cda664c0e4Christian Maeder -- use a dummy for properties
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaederpreludeConflicts :: [HsDecl] -> ([HsDecl], [Diagnosis])
b5699d97a9e2b4496f98d624f4b0a537986651c3Christian MaederpreludeConflicts =
3cafc73a998493f9ed3d5e934c0ab80bcfb465c2Christian Maeder foldr ( \ d (es, ds) -> let e = getHsDecl d
7bf6d421b0ea31ae63f1fe04919942b931abda47Christian Maeder p = [formSrcLoc $ srcLoc e]
7bf6d421b0ea31ae63f1fe04919942b931abda47Christian Maeder if preludeEntity e then
7c554e9d4a39b8eb3b0881f20807c95dd8e793aeChristian Maeder Diag Warning ("possible Prelude conflict:\n " ++ pp e) p : ds)
7bf6d421b0ea31ae63f1fe04919942b931abda47Christian Maeder else (d : es, ds)) ([], [])
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian MaederpreludeEntity :: (Printable i, Show t, DefinedNames i t) =>
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian Maeder DI i e p ds t [t] t -> Bool
7c554e9d4a39b8eb3b0881f20807c95dd8e793aeChristian MaederpreludeEntity d = case d of
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder HsFunBind _ ms -> any preludeMatch ms
7bf6d421b0ea31ae63f1fe04919942b931abda47Christian Maeder HsTypeSig _ ts _ _ -> any (flip Set.member preludeValues . pp) ts
7bf6d421b0ea31ae63f1fe04919942b931abda47Christian Maeder HsTypeDecl _ ty _ -> Set.member (pp $ definedType ty) preludeTypes
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder HsDataDecl _ _ ty cs _ -> Set.member (pp $ definedType ty) preludeTypes
7bf6d421b0ea31ae63f1fe04919942b931abda47Christian Maeder || any preludeConstr cs
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian Maeder _ -> True -- ignore others
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian MaederpreludeMatch :: Printable i =>
836e72a3c413366ba9801726f3b249c7791cb9caChristian Maeder HsMatchI i e p ds -> Bool
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian MaederpreludeMatch m = case m of
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder HsMatch _ n _ _ _ -> let s = pp n in
9c5b1136299d9052e4e995614a3a36a051a2682fChristian Maeder Set.member s preludeValues || prefixed s
bb3bdd4a260606a6184b5f5a5774ca6632ca597aChristian MaederpreludeConstr :: Printable i => HsConDeclI i t [t] -> Bool
e8a2ca3a7b3e9a19ef03b6b1c0b5d03dbad6463cChristian MaederpreludeConstr c = let s = pp $ case c of
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder HsConDecl _ _ _ n _ -> n
e76e6a43f51438215737d6fc176c89da05bb86daChristian Maeder HsRecDecl _ _ _ n _ -> n
4561227a776bdf0ab679b19fb92f1eaaed8786f7Christian Maeder in Set.member s preludeConstrs
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian MaedergenPrefixes :: [String]
ff9a53595208f532c25ac5168f772f48fd80fdb5Christian MaedergenPrefixes = ["$--", "default__", "derived__Prelude", "inst__Prelude"]
preludeValues :: Set.Set String
preludeValues = Set.fromList $ filter (not . prefixed) $ map pp
$ Map.keys $ values preludeSign
preludeConstrs :: Set.Set String
Set.filter ( \ s -> not (null s) && isUpper (head s)) preludeValues
preludeTypes :: Set.Set String