{- | Central data structures of the symbol table -} module Info(module Info, module Id, IdKind,TokenId,NewType,InfixClass(..),Pos ) where import IdKind(IdKind) import TokenId(TokenId) import NT import Util.Extra(Pos,strace) import SysDeps(PackedString,trace) import qualified Data.Map as Map import Syntax(InfixClass(..)) import Id(Id) import Maybe data IE = IEnone | IEsel | IEsome | IEabs | IEall deriving (Eq,Show) -- ^ This is "Interface Exports" -- -- > defined in a lattice IEall -- > / \ -- > | IEsome -- > IEsel | -- > | IEabs -- > \ / -- > IEnone -- > IEall -> exported (with all constructors/fields/methods) -- > IEsome -> exported with selected constructors/fields/methods -- > IEabs -> exported abstractly (without constructors/fields/methods) -- > IEnone -> not exported -- > IEsel -> selected constructors/fields/methods -- > (is exported, despite defn below!) isExported :: IE -> Bool isExported IEnone = False isExported IEsel = False isExported _ = True combIE :: IE -> IE -> IE combIE IEall _ = IEall combIE _ IEall = IEall combIE IEnone i = i combIE i IEnone = i combIE IEsome IEabs = IEsome combIE IEabs IEsome = IEsome combIE _ i = i -- | Patch newtype for exports (Its constructor must always be in the -- interface file, even if not visible in the importing module.) patchIE :: IE -> IE patchIE IEabs = IEsome patchIE ie = ie data DataKind = DataTypeSynonym Bool -- True <-> unboxed after expansion Int -- depth (used to determine -- which type synonym to expand) | DataNewType Bool -- always False [Id] -- constructor(one or zero) | Data Bool -- True <-> unboxed [Id] -- constructors | DataPrimitive Int -- size deriving (Show) -- | Given all the selector functions below, shouldn't these -- constructors be record constructors? -SamB data Info = InfoClear -- used to remove imported when redefining in mutally -- recursive modules and when compiling the prelude | InfoUsed Id -- unique [(IdKind,TokenId,PackedString,Pos)] -- occurrence where used | InfoUsedClass Id -- unique [(IdKind,TokenId,PackedString,Pos)] -- occurrence where used (Map.Map Id (PackedString,[Id],[(Id,Id)])) -- instances of the class -- the tree associates a type constructor with -- the module name, free variables and the superclass context -- of an instance | InfoData -- data type (algebraic, type synonym, ...) Id -- unique TokenId -- token of data type name IE -- is exported? NewType -- if type synonym: type it is defined to be -- if data or newtype: defined type -- e.g.: data Num a => Test a b = A a | B b -- NewType [1,2] [] [(NumId, 1)] -- [NTvar 1 Star, NTvar 2 Star, mkNTcons TestId -- [NTvar 1 Star, NTvar 2 Star]] DataKind -- kind of data type | InfoClass Id -- unique TokenId -- token of class name IE -- is exported? NewType -- pseudo type built from class and type variable -- (type of dictionary?) [Id] -- method ids refering to type declaration [Id] -- method ids refering to default definition -- ids in same position refer to same method -- => lists have same lengths (Map.Map Id (PackedString,[Id],[(Id,Id)])) -- instances of the class -- the tree associates a type constructor with -- the module name, free variables and the superclass context -- of an instance | InfoVar -- term variable Id -- unique TokenId -- token for name IE -- is exported? (InfixClass TokenId,Int) -- fixity NewType -- type (Maybe Int) -- arity (if available) | InfoConstr -- data constructor Id -- unique TokenId -- token for name IE -- is exported? (InfixClass TokenId,Int) -- fixity NewType -- type of the constructor [Maybe Id] -- field names (if they exist) Id -- data type to which constructor belongs | InfoField -- field name Id -- unique TokenId -- token for name IE -- is exported? [(Id,Int)] -- [(data constructor, offset for this constr.)] Id -- iData Id -- iSel -- unique tid [(constructor,offset)] type selector | InfoMethod -- for type declaration of method in a class definition Id -- unique TokenId -- token for method name IE -- is exported? (InfixClass TokenId,Int) -- fixity NewType (Maybe Int) -- arity (if available; here bogus) Id -- unique of class to which method belongs | InfoIMethod -- for definition in instance definition Id -- unique TokenId -- token for name NewType (Maybe Int) -- arity (if available) Id -- iMethod (0 after renaming) -- The type is NewType free instancs_ctx instance_type, -- for real type follow iMethod | InfoDMethod -- for default definition in class definition Id -- unique TokenId -- token for method name NewType (Maybe Int) -- arity (if available) Id -- class to which method belongs -- | Only used in "Export" | InfoInstance Id -- unique PackedString -- where it was defined NewType Id -- unique of class (of which this is instance) | InfoName Id -- unique TokenId -- token for name Int -- arity TokenId Bool --PHtprof indicates subfn -- inserted late to hold name and arity for some functions -- (second TokenId is profname ) deriving (Show) {- Template z (InfoUsed unique uses) = z (InfoUsedClass unique uses insts) = z (InfoData unique tid ie nt dk) = case dk of (DataTypeSynonym unboxed depth) -> (DataNewType unboxed constructors) -> (Data unboxed constrs) -> (DataPrimitive size) -> z (InfoClass unique tid ie nt ms ds insts) = z (InfoVar unique tid ie fix nt annot) = z (InfoConstr unique tid ie fix nt fields iType) = z (InfoField unique tid ie icon_offs iData iSel) = z (InfoMethod unique tid ie fix nt annot iClass) = z (InfoIMethod unique tid nt annot iMethod) = z (InfoDMethod unique tid nt annot iClass) = z (InfoInstance unique nt iClass) = z (InfoName pos unique tid Int ptid subfn) = --PHtprof -} clearI :: a -> Info clearI _ = InfoClear --isClear InfoClear = True --isClear _ = False isMethod :: Info -> Bool isMethod (InfoMethod unique tid ie fix nt annot iClass) = True isMethod _ = False isData :: Info -> Bool isData (InfoData unique tid exp nt dk) = True isData _ = False isRealData :: Info -> Bool isRealData (InfoData unique tid exp nt dk) = case dk of (DataTypeSynonym unboxed depth) -> False (DataNewType unboxed constructors) -> False (DataPrimitive size) -> True (Data unboxed constrs) -> True isRealData info = error ("isRealData " ++ show info) isRenamingFor :: Map.Map Id Info -> Info -> NewType isRenamingFor st (InfoData unique tid exp nt (DataTypeSynonym _ depth)) = nt isRenamingFor st info@(InfoData unique tid exp nt (DataNewType _ constrs)) = case constrs of [] -> error ("Problem with type of a foreign imported function:\n" ++"Cannot find constructor for newtype: "++show info) [c] -> case Map.lookup c st of Just i -> ntI i Nothing -> error ("Cannot find info for newtype constructor: " ++show info) isRenamingFor st info = error ("isRenamingFor " ++ show info) isDataUnBoxed :: Info -> Bool isDataUnBoxed (InfoData unique tid exp nt dk) = case dk of (DataTypeSynonym unboxed depth) -> unboxed (DataNewType unboxed constructors) -> unboxed (Data unboxed constrs) -> unboxed (DataPrimitive size) -> True isDataUnBoxed info = error ("isDataUnBoxed: " ++ show info) isField :: Info -> Bool isField (InfoField _ _ _ _ _ _) = True isField _ = False isClass :: Info -> Bool isClass (InfoClass _ _ _ _ _ _ _) = True isClass _ = False isUsedClass :: Info -> Bool isUsedClass (InfoUsedClass _ _ _) = True isUsedClass _ = False isConstr :: Info -> Bool isConstr (InfoConstr _ _ _ _ _ _ _) = True isConstr _ = False depthI :: Info -> Maybe Int depthI (InfoData unique tid exp nt dk) = case dk of (DataTypeSynonym unboxed depth) -> Just depth _ -> Nothing depthI _ = Nothing typeSynonymBodyI :: Info -> Maybe NewType typeSynonymBodyI (InfoData _ _ _ nt (DataTypeSynonym _ _)) = Just nt typeSynonymBodyI _ = Nothing updTypeSynonym :: Bool -> Int -> Info -> Info updTypeSynonym unboxed depth (InfoData unique tid exp nt dk) = case dk of (DataTypeSynonym _ _) -> (InfoData unique tid exp nt (DataTypeSynonym unboxed depth)) {- | Sets the unboxedness information in newtype info as given. -} updNewType :: Bool -> Info -> Info updNewType unboxed (InfoData unique tid exp nt dk) = case dk of (DataNewType _ constructors) -> InfoData unique tid exp nt (DataNewType unboxed constructors) {- | Sets the type information in variable info as given. Is only applied to identifiers without types,i.e. never methods of any kind! -} newNT :: NewType -> Info -> Info newNT nt (InfoVar unique tid ie fix _ annot) = InfoVar unique tid ie fix nt annot ntI :: Info -> NewType ntI i = fromJust (maybeNtI i) maybeNtI :: Info -> Maybe NewType maybeNtI (InfoData unique tid ie nt dk) = Just nt -- maybeNtI (InfoClass unique tid ie nt ms ds) = Just nt --- Not needed? maybeNtI (InfoVar unique tid ie fix nt annot) = Just nt maybeNtI (InfoConstr unique tid ie fix nt fields iType) = Just nt maybeNtI (InfoMethod unique tid ie fix nt annot iClass) = Just nt maybeNtI (InfoIMethod unique tid nt annot iMethod) = Just nt -- Work here? maybeNtI (InfoDMethod unique tid nt annot iClass) = Just nt maybeNtI _ = Nothing strictI :: Info -> [Bool] strictI (InfoConstr _ _ _ _ (NewType free [] ctx nts) _ _) = map strictNT (init nts) strictI _ = [] -- Not strict in any argument so it doesn't matter if we return empty list qDefI :: Info -> Bool qDefI (InfoUsed _ _) = False qDefI (InfoUsedClass _ _ _) = False qDefI _ = True uniqueI :: Info -> Id uniqueI (InfoUsed unique _) = unique uniqueI (InfoUsedClass unique _ _) = unique uniqueI (InfoData unique tid ie nt dk) = unique uniqueI (InfoClass unique _ _ _ _ _ _) = unique uniqueI (InfoVar unique _ _ _ _ _) = unique uniqueI (InfoConstr unique _ _ _ _ _ _) = unique uniqueI (InfoField unique _ _ _ _ _) = unique uniqueI (InfoMethod unique _ _ _ _ _ _) = unique uniqueI (InfoIMethod unique _ _ _ _) = unique uniqueI (InfoDMethod unique _ _ _ _) = unique uniqueI (InfoInstance unique _ _ _) = unique uniqueI (InfoName unique _ _ _ _) = unique --PHtprof descI :: Info -> String descI (InfoUsed _ _) = "InfoUsed" descI (InfoUsedClass _ _ _) = "InfoUsedClass" descI (InfoData _ _ _ _ _ ) = "InfoData" descI (InfoClass _ _ _ _ _ _ _) = "InfoClass" descI (InfoVar _ _ _ _ _ _) = "InfoVar" descI (InfoConstr _ _ _ _ _ _ _) = "InfoConstr" descI (InfoField _ _ _ _ _ _) = "InfoField" descI (InfoMethod _ _ _ _ _ _ _) = "InfoMethod" descI (InfoIMethod _ _ _ _ _) = "InfoIMethod" descI (InfoDMethod _ _ _ _ _) = "InfoDMethod" descI (InfoInstance _ _ _ _) = "InfoInstance" descI (InfoName _ _ _ _ _) = "InfoName" descI _ = "InfoUnknown!" tidI :: Info -> TokenId tidI (InfoData unique tid exp nt dk) = tid tidI (InfoClass u tid _ _ _ _ _) = tid tidI (InfoVar u tid _ _ _ _) = tid tidI (InfoConstr u tid _ _ _ _ _) = tid tidI (InfoField u tid _ _ _ _) = tid tidI (InfoMethod u tid _ _ _ _ _) = tid tidI (InfoIMethod u tid _ _ _) = tid tidI (InfoDMethod u tid _ _ _) = tid tidI (InfoName u tid _ _ _) = tid --PHtprof tidI (InfoUsedClass u ((_,tid,_,_):_) _) = tid --MW tidI (InfoUsed u ((_,tid,_,_):_)) = tid --TS tidI info = error ("tidI (Info.hs) called with bad info:\n" ++ show info) cmpTid :: TokenId -> Info -> Bool cmpTid t (InfoUsed _ _) = False cmpTid t (InfoUsedClass _ _ _) = False cmpTid t i = tidI i == t methodsI :: Info -> [(Id,Id)] methodsI (InfoClass u tid ie nt ms ds inst) = zip ms ds instancesI :: Info -> Map.Map Id (PackedString,[Id],[(Id,Id)]) instancesI (InfoClass u tid e nt ms ds inst) = inst instancesI info@(InfoUsedClass u uses inst) = strace ("***instanceI(1) "++show info++"\n") inst instancesI info = strace ("***instanceI(2) "++show info++"\n") Map.empty -- This is a lie!!! For some reason has this class no real entry {- | Return identifiers of all superclasses of the class which is described by given info. -} superclassesI :: Info -> [Id] superclassesI (InfoClass _ _ _ (NewType _ [] ctxs _) _ _ _) = map fst ctxs superclassesI info = error ("superclassesI " ++ show info) {- | Add information about an instance to info of a class. If information about this instance exists already in info, then info left unchanged. type constructor -> free type variables -> context -> class info -> class info -} addInstanceI :: Id -> PackedString -> [Id] -> [(Id,Id)] -> Info -> Info addInstanceI con loc free ctxs info@(InfoClass u tid e nt ms ds inst) = case Map.lookup con inst of Just _ -> info Nothing -> InfoClass u tid e nt ms ds (Map.insert con (loc,free,ctxs) inst) addInstanceI con loc free ctxs info@(InfoUsedClass u uses inst) = case Map.lookup con inst of Just _ -> info Nothing -> InfoUsedClass u uses (Map.insert con (loc,free,ctxs) inst) addInstanceI con loc free ctxs (InfoUsed u uses) = addInstanceI con loc free ctxs (InfoUsedClass u uses Map.empty) {- | In joining two trees for describing instances the second one gets precedence in case of conflict. -} joinInsts :: Map.Map Id a -> Map.Map Id a -> Map.Map Id a joinInsts inst inst' = foldr (\(k,v) inst -> Map.insert k v inst) inst (Map.toList inst') {- | Determine constructors of a type from the info of the type -} constrsI :: Info -> [Id] constrsI (InfoName unique tid i ptid _) = [unique] --PHtprof -- ABOVE: this is a lie! but it is consistent with belongstoI :-) constrsI (InfoData unique tid exp nt dk) = case dk of (DataTypeSynonym unboxed depth) -> strace ("Constr of type synonym "++show tid++"\n") [] (DataNewType unboxed constructors) -> constructors (DataPrimitive size) -> strace ("Constr of data primitive "++show tid++"\n") [] (Data unboxed constrs) -> constrs constrsI info = error ("constrsI " ++ show info) updConstrsI :: Info -> [Id] -> Info updConstrsI (InfoData unique tid exp nt dk) constrs' = case dk of (Data unboxed constrs) -> InfoData unique tid exp nt (Data unboxed constrs') fieldsI :: Info -> [Maybe Id] fieldsI (InfoConstr unique tid ie fix nt fields iType) = fields combInfo :: Info -> Info -> Info combInfo InfoClear info' = info' combInfo (InfoUsed _ w) (InfoUsed u' w') = InfoUsed u' (w++w') combInfo (InfoUsed _ _) info' = info' combInfo info InfoClear = info combInfo info (InfoUsed _ _) = info combInfo i1@(InfoUsedClass _ uses insts) i2@(InfoClass u tid exp nt ms ds insts') = InfoClass u tid exp nt ms ds (joinInsts insts' insts) combInfo i1@(InfoClass _ tid exp nt ms ds insts) i2@(InfoUsedClass u uses insts') = InfoClass u tid exp nt ms ds (joinInsts insts' insts) combInfo (InfoClass u tid exp nt ms ds insts) (InfoClass u' tid' exp' nt' [] [] insts') = InfoClass u tid (combIE exp exp') nt ms ds (joinInsts insts' insts) combInfo (InfoClass u tid exp nt ms ds insts) (InfoClass u' tid' exp' nt' ms' ds' insts') = InfoClass u tid (combIE exp exp') nt' ms' ds' (joinInsts insts' insts) combInfo info@(InfoData u tid exp nt dk) info'@(InfoData u' tid' exp' nt' dk') = case dk' of Data unboxed [] -> info _ -> if isExported exp' then info' else info combInfo info info' = -- Use new (if possible) so that code can override old imported if isExported (expI info) then info else info' expI :: Info -> IE expI (InfoData _ _ ie _ _) = ie expI (InfoClass _ _ ie _ _ _ _) = ie expI (InfoVar _ _ ie _ _ _) = ie expI (InfoConstr _ _ ie _ _ _ _) = ie expI (InfoField _ _ ie _ _ _) = ie -- Data contains export info expI (InfoMethod _ _ ie _ _ _ _) = ie expI (InfoIMethod _ _ _ _ _) = IEnone expI (InfoDMethod _ _ _ _ _) = IEnone expI info = IEnone -- I get InfoUsed here !!! -- | arity without context (Visible) arityVI :: Info -> Int arityVI (InfoVar _ _ _ _ _ (Just arity)) = arity arityVI (InfoConstr _ _ _ _ (NewType _ _ _ nts) _ _) = length nts - 1 arityVI (InfoMethod _ _ _ _ _ (Just arity) _) = 1 arityVI (InfoIMethod _ _ _ (Just arity) _) = arity arityVI (InfoDMethod _ _ _ (Just arity) _) = arity arityVI (InfoName _ _ arity _ _) = arity --PHtprof -- | arity with context arityI :: Info -> Int arityI (InfoVar _ _ _ _ (NewType _ _ ctx _) (Just arity)) = length ctx + arity arityI (InfoVar _ _ _ _ _ (Just arity)) = arity -- NR Generated after type deriving arityI (InfoConstr _ _ _ _ (NewType _ _ _ nts) _ _) = length nts - 1 arityI (InfoMethod _ _ _ _ _ (Just arity) _) = 1 -- Wrong !!! -- arityI (InfoIMethod _ _ (NewType _ _ ctx _) (Just arity) _) -- = length ctx + arity arityI (InfoDMethod _ _ (NewType _ _ ctx _) (Just arity) _) = length ctx + arity + 1 -- +1 is for the dictionary arityI (InfoName unique tid arity ptid _) = arity --PHtprof arityI info = error ("arityI " ++ show info) arityIM :: Info -> Int arityIM (InfoMethod _ _ _ _ (NewType _ _ ctx _) (Just arity) _) = length ctx + arity fixityI :: Info -> (InfixClass TokenId, Int) fixityI (InfoVar unique tid ie fix nt annot) = fix fixityI (InfoConstr unique tid ie fix nt fields iType) = fix fixityI (InfoMethod unique tid ie fix nt annot iClass) = fix fixityI _ = (InfixDef,9::Int) belongstoI :: Info -> Id belongstoI (InfoConstr unique tid ie fix nt fields iType) = iType belongstoI (InfoField unique tid ie icon_offs iData iSel) = iData belongstoI (InfoMethod unique tid ie fix nt annot iClass) = iClass belongstoI (InfoIMethod unique tid nt annot iMethod) = iMethod -- Maybe ought to be it's own function belongstoI (InfoDMethod unique tid nt annot iClass) = iClass belongstoI (InfoInstance unique mrs nt iClass) = iClass belongstoI (InfoName unique tid i ptid _) = unique --PHtprof -- ABOVE: this is a lie! but it is consistent with constrsI :-) belongstoI info = error ("belongstoI " ++ show info) profI :: Info -> TokenId profI (InfoData unique tid exp nt dk) = tid profI (InfoClass u tid _ _ _ _ _) = tid profI (InfoVar u tid _ _ _ _) = tid profI (InfoConstr u tid _ _ _ _ _) = tid profI (InfoField u tid _ _ _ _) = tid profI (InfoMethod u tid _ _ _ _ _) = tid profI (InfoIMethod u tid _ _ _) = tid profI (InfoDMethod u tid _ _ _) = tid profI (InfoName u tid _ ptid _) = ptid --PHtprof profI info = error ("profII (Info.hs) " ++ show info)