{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
#include "GhclibHsVersions.h"
module Avail (
Avails,
AvailInfo(..),
avail,
availsToNameSet,
availsToNameSetWithSelectors,
availsToNameEnv,
availName, availNames, availNonFldNames,
availNamesWithSelectors,
availFlds,
availsNamesWithOccs,
availNamesWithOccs,
stableAvailCmp,
plusAvail,
trimAvail,
filterAvail,
filterAvails,
nubAvails
) where
import GhcPrelude
import Name
import NameEnv
import NameSet
import FieldLabel
import Binary
import ListSetOps
import Outputable
import Util
import Data.Data ( Data )
import Data.List ( find )
import Data.Function
data AvailInfo
= Avail Name
| AvailTC
Name
[Name]
[FieldLabel]
deriving ( Eq
, Data )
type Avails = [AvailInfo]
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2
stableAvailCmp (Avail {}) (AvailTC {}) = LT
stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
(n `stableNameCmp` m) `thenCmp`
(cmpList stableNameCmp ns ms) `thenCmp`
(cmpList (stableNameCmp `on` flSelector) nfs mfs)
stableAvailCmp (AvailTC {}) (Avail {}) = GT
avail :: Name -> AvailInfo
avail n = Avail n
availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldr add emptyNameSet avails
where add avail set = extendNameSetList set (availNames avail)
availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
where add avail set = extendNameSetList set (availNamesWithSelectors avail)
availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
availsToNameEnv avails = foldr add emptyNameEnv avails
where add avail env = extendNameEnvList env
(zip (availNames avail) (repeat avail))
availName :: AvailInfo -> Name
availName (Avail n) = n
availName (AvailTC n _ _) = n
availNames :: AvailInfo -> [Name]
availNames (Avail n) = [n]
availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
availNamesWithSelectors :: AvailInfo -> [Name]
availNamesWithSelectors (Avail n) = [n]
availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
availNonFldNames :: AvailInfo -> [Name]
availNonFldNames (Avail n) = [n]
availNonFldNames (AvailTC _ ns _) = ns
availFlds :: AvailInfo -> [FieldLabel]
availFlds (AvailTC _ _ fs) = fs
availFlds _ = []
availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]
availsNamesWithOccs = concatMap availNamesWithOccs
availNamesWithOccs :: AvailInfo -> [(Name, OccName)]
availNamesWithOccs (Avail n) = [(n, nameOccName n)]
availNamesWithOccs (AvailTC _ ns fs)
= [ (n, nameOccName n) | n <- ns ] ++
[ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]
plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
plusAvail a1 a2
| debugIsOn && availName a1 /= availName a2
= pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
plusAvail a1@(Avail {}) (Avail {}) = a1
plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2
plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1
plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
= case (n1==s1, n2==s2) of
(True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
(fs1 `unionLists` fs2)
(True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
(fs1 `unionLists` fs2)
(False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
(fs1 `unionLists` fs2)
(False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
(fs1 `unionLists` fs2)
plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
= AvailTC n1 ss1 (fs1 `unionLists` fs2)
plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2)
= AvailTC n1 ss2 (fs1 `unionLists` fs2)
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
trimAvail :: AvailInfo -> Name -> AvailInfo
trimAvail (Avail n) _ = Avail n
trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
Just x -> AvailTC n [] [x]
Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []
filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails keep avails = foldr (filterAvail keep) [] avails
filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
filterAvail keep ie rest =
case ie of
Avail n | keep n -> ie : rest
| otherwise -> rest
AvailTC tc ns fs ->
let ns' = filter keep ns
fs' = filter (keep . flSelector) fs in
if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest
nubAvails :: [AvailInfo] -> [AvailInfo]
nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)
where
add env avail = extendNameEnv_C plusAvail env (availName avail) avail
instance Outputable AvailInfo where
ppr = pprAvail
pprAvail :: AvailInfo -> SDoc
pprAvail (Avail n)
= ppr n
pprAvail (AvailTC n ns fs)
= ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi
, fsep (punctuate comma (map (ppr . flLabel) fs))])
instance Binary AvailInfo where
put_ bh (Avail aa) = do
putByte bh 0
put_ bh aa
put_ bh (AvailTC ab ac ad) = do
putByte bh 1
put_ bh ab
put_ bh ac
put_ bh ad
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
return (Avail aa)
_ -> do ab <- get bh
ac <- get bh
ad <- get bh
return (AvailTC ab ac ad)