Info is imported by: Case, CaseHelp, CaseLib, CaseOpt, DbgTrans, Export, FSLib, FixSyntax, Foreign, GcodeFix, ImportState, IntState, Need, PreImport, PrettySyntax, RenameLib, ReportImports, TokenInt, Type, TypeCtx, TypeLib, TypeUnify, TypeUtil.
{- ---------------------------------------------------------------------------
Central data structures of the symbol table
-}
module Info(module Info, IdKind,TokenId,NewType,InfixClass(..),Pos(..) ,AssocTree(..),Tree{-,PackedString-}) where import IdKind(IdKind) import TokenId(TokenId) import NT import Extra(Pos(..),sndOf,strace) import PackedString(PackedString) import Tree234 import AssocTree import Syntax(InfixClass(..)) import Id(Id) data IE = IEnone | IEsel | IEabs | IEall deriving (Eq,Show) -- This is "Interface Exports" -- defined in a lattice IEall -- / -- IEsel IEabs -- \ / -- IEnone -- IEall -> exported (with all constructors/methods) -- IEabs -> exported abstractly (without constructors) -- IEsel -> selector (named fields) (is exported, despite defn below!) -- IEnone -> not exported isExported IEnone = False isExported IEsel = False isExported _ = True combIE IEall _ = IEall combIE _ IEall = IEall combIE IEnone i = i combIE i IEnone = i combIE _ i = i 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) 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 (AssocTree Int ([Int],[(Int,Int)])) -- instances of the class -- the tree associates a type constructor with -- the free variables and the superclass context -- of an instance | InfoData -- data type (algebraic, type synonym, ...) Id -- unique TokenId -- token of data type name IE 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, NTvar 2, NTcons TestId -- [NTvar 1, NTvar 2]] DataKind -- kind of data type | InfoClass Int -- unique TokenId -- token of class name IE 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 (AssocTree Int ([Int],[(Int,Int)])) -- instances of the class -- the tree associates a type constructor with -- the free variables and the superclass context -- of an instance | InfoVar -- term variable Int -- unique TokenId -- token for name (InfixClass TokenId,Int) -- fixity IE NewType -- type (Maybe Int) -- arity (if available) | InfoConstr -- data constructor Int -- unique TokenId -- token for name (InfixClass TokenId,Int) -- fixity NewType -- type of the constructor [Maybe Int] -- field names (if they exist) Int -- data type to which constructor belongs | InfoField -- field name Id -- unique TokenId -- token for name [(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 (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 | InfoInstance -- Only used in Export Id -- unique 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 exp nt dk) =
case dk of
(DataTypeSynonym unboxed depth) ->
(DataNewType unboxed constructors) ->
(Data unboxed constrs) ->
(DataPrimitive size) ->
z (InfoClass unique tid exp nt ms ds insts) =
z (InfoVar unique tid fix exp nt annot) =
z (InfoConstr unique tid fix nt fields iType) =
z (InfoField unique tid icon_offs iData iSel) =
z (InfoMethod unique tid 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 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 :: AssocTree Int 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 ("Cannot find constructor for newtype: "++show info) [c] -> case lookupAT st c 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 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 fix exp _ annot) = InfoVar unique tid fix exp nt annot ntI :: Info -> NewType ntI (InfoData unique tid exp nt dk) = nt -- ntI (InfoClass unique tid exp nt ms ds) = nt --- Not needed? ntI (InfoVar unique tid fix exp nt annot) = nt ntI (InfoConstr unique tid fix nt fields iType) = nt ntI (InfoMethod unique tid fix nt annot iClass) = nt ntI (InfoIMethod unique tid nt annot iMethod) = nt -- Work here? ntI (InfoDMethod unique tid nt annot iClass) = nt strictI :: Info -> [Bool] strictI (InfoConstr unique tid fix (NewType free [] ctx nts) fields iType) = map strictNT (init nts) strictI _ = [] -- Not strict in any argument so it doesn't matter if we return empty list qDefI (InfoUsed _ _) = False qDefI (InfoUsedClass _ _ _) = False qDefI _ = True uniqueI (InfoUsed unique _) = unique uniqueI (InfoUsedClass unique _ _) = unique uniqueI (InfoData unique tid exp nt dk) = unique uniqueI (InfoClass unique _ _ _ _ _ _) = unique uniqueI (InfoVar unique _ _ _ _ _) = unique uniqueI (InfoConstr unique _ _ _ _ _) = unique uniqueI (InfoField unique tid icon_offs iData iSel) = unique uniqueI (InfoMethod unique _ _ _ _ _) = unique uniqueI (InfoIMethod unique _ _ _ _) = unique uniqueI (InfoDMethod unique _ _ _ _) = unique uniqueI (InfoInstance unique _ _) = unique uniqueI (InfoName unique _ _ _ _) = unique --PHtprof 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 icon_offs iData iSel) = tid tidI (InfoMethod u tid _ _ _ _) = tid tidI (InfoIMethod u tid _ _ _) = tid tidI (InfoDMethod u tid _ _ _) = tid tidI (InfoName u tid _ _ _) = tid --PHtprof 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 -> [(Int,Int)] methodsI (InfoClass u tid e nt ms ds inst) = zip ms ds instancesI :: Info -> Tree (Int,([Int],[(Int,Int)])) 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") initAT -- 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 -> [Int] superclassesI (InfoClass u tid e (NewType free [] ctxs nts) ms ds inst) = 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 :: Int -> [Int] -> [(Int,Int)] -> Info -> Info addInstanceI con free ctxs info@(InfoClass u tid e nt ms ds inst) = case lookupAT inst con of Just _ -> info Nothing -> InfoClass u tid e nt ms ds (addAT inst sndOf con (free,ctxs)) addInstanceI con free ctxs info@(InfoUsedClass u uses inst) = case lookupAT inst con of Just _ -> info Nothing -> InfoUsedClass u uses (addAT inst sndOf con (free,ctxs)) addInstanceI con free ctxs (InfoUsed u uses) = addInstanceI con free ctxs (InfoUsedClass u uses initAT)
{-
In joining two trees for describing instances the second one gets
precedence in case of conflict.
-}
joinInsts :: AssocTree Int a -> AssocTree Int a -> AssocTree Int a joinInsts inst inst' = foldr ( \ (k,v) inst -> addAT inst sndOf k v) inst (treeMapList (:) inst')
{- Determine constructors of a type from the info of the type -}
constrsI :: Info -> [Int] constrsI (InfoName unique tid i ptid _) = [unique] --PHtprof -- ^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) [] (DataNewType unboxed constructors) -> constructors (DataPrimitive size) -> strace ("Constr of data primitive " ++ show tid) [] (Data unboxed constrs) -> constrs constrsI info = error ("constrsI " ++ show info) updConstrsI :: Info -> [Int] -> Info updConstrsI (InfoData unique tid exp nt dk) constrs' = case dk of (Data unboxed constrs) -> InfoData unique tid exp nt (Data unboxed constrs') fieldsI (InfoConstr unique tid 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 (InfoData unique tid exp nt dk) = exp expI (InfoClass unique tid exp nt ms ds insts) = exp expI (InfoVar unique tid fix exp nt annot) = exp expI (InfoConstr unique tid fix nt fields iType) = IEnone -- Data contains export info expI (InfoField unique tid icon_offs iData iSel) = IEnone -- Data contains export info expI (InfoMethod unique tid fix nt annot iClass) = IEnone expI (InfoIMethod unique tid nt annot iMethod) = IEnone expI (InfoDMethod unique tid nt annot iClass) = IEnone expI info = IEnone -- I get InfoUsed here !!! -- arity without context (Visible) arityVI (InfoVar unique tid fix exp nt (Just arity)) = arity arityVI (InfoConstr unique tid fix (NewType _ _ _ nts) fields iType) = length nts - 1 arityVI (InfoMethod unique tid fix nt (Just arity) iClass) = 1 arityVI (InfoIMethod unique tid nt (Just arity) iMethod) = arity arityVI (InfoDMethod unique tid nt (Just arity) iClass) = arity arityVI (InfoName unique tid arity ptid _) = arity --PHtprof -- arity with context arityI (InfoVar unique tid fix exp (NewType _ _ ctxs _) (Just arity)) = length ctxs + arity arityI (InfoVar unique tid fix exp NoType (Just arity)) = arity -- NR Generated after type deriving arityI (InfoConstr unique tid fix (NewType _ _ _ nts) fields iType) = length nts - 1 arityI (InfoMethod unique tid fix nt (Just arity) iClass) = 1 -- Wrong !!! -- arityI (InfoIMethod unique tid (NewType _ _ ctxs _) (Just arity) iMethod) = -- length ctxs + arity arityI (InfoDMethod unique tid (NewType _ _ ctxs _) (Just arity) iClass) = length ctxs + arity + 1 {- 1 is for the dictionary -} arityI (InfoName unique tid arity ptid _) = arity --PHtprof arityI info = error ("arityI " ++ show info) arityIM (InfoMethod unique tid fix (NewType _ _ ctx _) (Just arity) iClass) = length ctx + arity fixityI (InfoVar unique tid fix exp nt annot) = fix fixityI (InfoConstr unique tid fix nt fields iType) = fix fixityI (InfoMethod unique tid fix nt annot iClass) = fix fixityI _ = (InfixDef,9::Int) belongstoI :: Info -> Int belongstoI (InfoConstr unique tid fix nt fields iType) = iType belongstoI (InfoField unique tid icon_offs iData iSel) = iData belongstoI (InfoMethod unique tid 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 nt iClass) = iClass belongstoI (InfoName unique tid i ptid _) = unique --PHtprof -- ^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 icon_offs iData iSel) = 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)
(HTML for this module was generated on May 15, 2003. About the conversion tool.)