uuagc-0.9.5: src/DepTypes.hs
module DepTypes where
import CommonTypes
-------------------------------------------------------------------------------
-- Class definitions
-------------------------------------------------------------------------------
class HasAttrAndField a where
getField :: a -> Identifier
getAttr :: a -> Identifier
class ContainsTrace a where
addTraceElem :: TraceElem -> a -> a
addTrace :: Trace -> a -> a
-------------------------------------------------------------------------------
-- Vertices
-------------------------------------------------------------------------------
-- kan helaas niet met named fields, want dat levert een conflict op in de uniekheid vd naamgeving.
-- ERROR "CommonTypes.hs" (line 44): Repeated definition for selector "nt"
data Vertex = Local Name Name Name -- lhs nt, constructor, attribute
| LHSInh Name Name Name -- lhs nt, constructor, attribute
| LHSSyn Name Name Name -- lhs nt, constructor, attribute
| ShRHSInh Name Name Name Name -- lhs nt, constructor, field, attribute !!rhs nt not known, equal to RHSInh!!
| ShRHSSyn Name Name Name Name -- lhs nt, constructor, field, attribute !!rhs nt not known, equal to RHSSyn!!
| RHSInh Name Name Name Name Name -- rhs nt, lhs nt, constructor, field, attribute
| RHSSyn Name Name Name Name Name -- rhs nt, lhs nt, constructor, field, attribute
| NTInh Name Name -- nt, attribute
| NTSyn Name Name -- nt, attribute
instance Eq Vertex where
Local lhs1 con1 attr1 == Local lhs2 con2 attr2 = lhs1==lhs2 && con1==con2 && attr1==attr2
LHSInh lhs1 con1 attr1 == LHSInh lhs2 con2 attr2 = lhs1==lhs2 && con1==con2 && attr1==attr2
LHSSyn lhs1 con1 attr1 == LHSSyn lhs2 con2 attr2 = lhs1==lhs2 && con1==con2 && attr1==attr2
ShRHSInh lhs1 con1 name1 attr1 == ShRHSInh lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2
ShRHSSyn lhs1 con1 name1 attr1 == ShRHSSyn lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2
RHSInh rhs1 lhs1 con1 name1 attr1 == RHSInh rhs2 lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2
RHSSyn rhs1 lhs1 con1 name1 attr1 == RHSSyn rhs2 lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2
ShRHSInh lhs1 con1 name1 attr1 == RHSInh _ lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2
ShRHSSyn lhs1 con1 name1 attr1 == RHSSyn _ lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2
RHSInh _ lhs1 con1 name1 attr1 == ShRHSInh lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2
RHSSyn _ lhs1 con1 name1 attr1 == ShRHSSyn lhs2 con2 name2 attr2 = lhs1==lhs2 && con1==con2 && name1==name2 && attr1==attr2
NTInh nt1 attr1 == NTInh nt2 attr2 = nt1==nt2 && attr1==attr2
NTSyn nt1 attr1 == NTSyn nt2 attr2 = nt1==nt2 && attr1==attr2
_ == _ = False
instance HasAttrAndField Vertex where
getAttr (Local _ _ attr) = attr
getAttr (LHSInh _ _ attr) = attr
getAttr (LHSSyn _ _ attr) = attr
getAttr (ShRHSInh _ _ _ attr) = attr
getAttr (ShRHSSyn _ _ _ attr) = attr
getAttr (RHSInh _ _ _ _ attr) = attr
getAttr (RHSSyn _ _ _ _ attr) = attr
getAttr (NTInh _ attr) = attr
getAttr (NTSyn _ attr) = attr
getField (Local _ _ _) = nullIdent
getField (LHSInh _ _ _) = _LHS
getField (LHSSyn _ _ _) = _LHS
getField (ShRHSInh _ _ fld _) = fld
getField (ShRHSSyn _ _ fld _) = fld
getField (RHSInh _ _ _ fld _) = fld
getField (RHSSyn _ _ _ fld _) = fld
getField (NTInh _ _) = nullIdent
getField (NTSyn _ _) = nullIdent
instance Show Vertex where
show (Local lhs con attr) = show lhs ++ "." ++ show attr ++ "(L," ++ show lhs ++ "." ++ show con ++ ")"
show (LHSInh lhs con attr) = show lhs ++ "." ++ show attr ++ "(I," ++ show lhs ++ "." ++ show con ++ ".lhs)"
show (LHSSyn lhs con attr) = show lhs ++ "." ++ show attr ++ "(S," ++ show lhs ++ "." ++ show con ++ ".lhs)"
show (ShRHSInh lhs con name attr) = ""
show (ShRHSSyn lhs con name attr) = ""
show (RHSInh rhs lhs con name attr) = show rhs ++ "." ++ show attr ++ "(I," ++ show lhs ++ "." ++ show con ++ "." ++ show name ++ ")"
show (RHSSyn rhs lhs con name attr) = show rhs ++ "." ++ show attr ++ "(S," ++ show lhs ++ "." ++ show con ++ "." ++ show name ++ ")"
show (NTInh nt attr) = ""
show (NTSyn nt attr) = ""
-------------------------------------------------------------------------------
-- Streams, results
-------------------------------------------------------------------------------
type UseStream = (Vertex,Stream)
type Stream = [Result]
type Result = ([UsedAttr],[UsedAttr])
data UsedAttr = Loc Name Name Trace -- field name and attribute name
| Glo Name Trace -- attribute name
-- lhs en rhs slaan op de lhs en rhs van een attribute equation en niet van de productie!!
data TraceElem = TE { lineNr :: Int
, nt :: Nonterminal
, prod :: Name
, lhsNt :: Nonterminal
, lhsFld :: Name
, lhsAttr :: Name
, rhsFld :: Name
, rhsAttr :: Name } deriving Show
type Trace = [TraceElem]
getTrace :: UsedAttr -> Trace
getTrace (Loc _ _ trace) = trace
getTrace (Glo _ trace) = trace
toPair :: UsedAttr -> (Name,Trace)
toPair (Loc _ attr trace) = (attr,trace)
toPair (Glo attr trace) = (attr,trace)
-- de Eq op Res negeert de trace, want dit is geen onderdeel van het resultaat, maar een oorzaak ervan.
-- hierdoor kan gewoon de elem functie op sets van resultaten gebruikt worden.
instance Eq UsedAttr where
Loc fld1 attr1 _ == Loc fld2 attr2 _ = fld1==fld2 && attr1==attr2
Glo attr1 _ == Glo attr2 _ = attr1==attr2
_ == _ = False
instance Show UsedAttr where
show (Loc fld attr trace) = "(" ++ show fld ++ "," ++ show attr ++ ")"
show (Glo attr trace) = show attr
instance HasAttrAndField UsedAttr where
getAttr (Loc _ attr _) = attr
getAttr (Glo attr _) = attr
getField (Loc fld attr _) = fld
getField _ = nullIdent
instance ContainsTrace UsedAttr where
addTraceElem newtre (Loc fld attr oldtr) = Loc fld attr (newtre:oldtr)
addTraceElem newtre (Glo attr oldtr) = Glo attr (newtre:oldtr)
addTrace newtr (Loc fld attr oldtr) = Loc fld attr (newtr++oldtr)
addTrace newtr (Glo attr oldtr) = Glo attr (newtr++oldtr)
instance ContainsTrace Result where
addTraceElem newcs (set,upd) = (map (addTraceElem newcs) set,map (addTraceElem newcs) upd)
addTrace newcss (set,upd) = (map (addTrace newcss) set,map (addTrace newcss) upd)
instance ContainsTrace Stream where
addTraceElem newcs stream = map (addTraceElem newcs) stream
addTrace newcss stream = map (addTrace newcss) stream