INCLUDE "ErrorMessages.ag" imports { import UU.Scanner.Position(Pos(..), noPos) import ErrorMessages import Data.List(mapAccumL) import GrammarInfo import qualified Control.Monad.Error.Class as Err } { instance Err.Error Error where noMsg = Err.strMsg "error" strMsg = CustomError False noPos . pp } { isError :: Options -> Error -> Bool isError _ (ParserError _ _ _ ) = True isError _ (DupAlt _ _ _ ) = False isError _ (DupSynonym _ _ ) = False isError _ (DupSet _ _ ) = False isError _ (DupInhAttr _ _ _ ) = True isError _ (DupSynAttr _ _ _ ) = True isError _ (DupChild _ _ _ _ ) = False isError _ (DupRule _ _ _ _ _) = True isError _ (DupSig _ _ _ ) = False isError _ (UndefNont _ ) = True isError _ (UndefAlt _ _ ) = True isError _ (UndefChild _ _ _ ) = True isError _ (MissingRule _ _ _ _ ) = False isError _ (SuperfluousRule _ _ _ _ ) = False isError _ (UndefLocal _ _ _ ) = True isError _ (ChildAsLocal _ _ _ ) = False isError _ (UndefAttr _ _ _ _ _) = True isError _ (CyclicSet _ ) = True isError _ (CustomError w _ _ ) = not w isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts isError _ (MissingTypeSig _ _ _ ) = False isError _ (MissingInstSig _ _ _ ) = True isError _ (DupUnique _ _ _ ) = False isError _ (MissingUnique _ _ ) = True isError _ (MissingSyn _ _ ) = True isError _ (MissingNamedRule _ _ _) = True isError _ (DupRuleName _ _ _) = True isError _ (HsParseError _ _) = True isError _ (Cyclic _ _ _) = True isError _ (IncompatibleVisitKind _ _ _ _) = True isError _ (IncompatibleRuleKind _ _) = True isError _ (IncompatibleAttachKind _ _) = True cycleIsDangerous :: Options -> Bool cycleIsDangerous opts = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ] } ATTR Error [ options:{Options} verbose:{Bool} | | pp :{PP_Doc} me :SELF ] ATTR Errors [ options:{Options} dups : {[String]} | | pp USE {>-<} {text ""} : {PP_Doc} ] SEM Errors | * loc.verbose = verbose @lhs.options | Cons loc.str = disp @hd.pp 5000 "" lhs.pp = if @loc.str `elem` @lhs.dups then @tl.pp else @hd.pp >-< @tl.pp tl.dups = @loc.str : @lhs.dups | Nil lhs.pp = text "" SEM Error | ParserError lhs.pp = let mesg = text ("parser expecting " ++ @problem) pat = text "" help = text "" act = text @action in ppError (isError @lhs.options @me) @pos mesg pat help act @lhs.verbose | HsParseError lhs.pp = ppError True @pos (text @msg) (text "") (text "") (text "Correct the syntax of the Haskell code.") @lhs.verbose | DupAlt lhs.pp = let mesg = wfill ["Repeated definition for alternative", getName @con ,"of nonterminal", getName @nt, "." ] >-< wfill ["First definition:", (showPos @occ1),"."] >-< wfill ["Other definition:", (showPos @con),"."] pat = "DATA" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< "...") >-< indent 2 ("|" >#< getName @con >#< "...") help = wfill ["The nonterminal",getName @nt,"has more than one alternative that" ,"is labelled with the constructor name",getName @con,"." ,"You should either rename or remove enough of them to make all" ,"constructors of",getName @nt,"uniquely named." ] act = wfill [ "The first alternative of name",getName @con ,"you have given for nonterminal",getName @nt ,"is considered valid. All other alternatives have been discarded." ] in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose | DupSynonym lhs.pp = let mesg = wfill ["Definition of type synonym", getName @nt, "clashes with another" ,"type synonym." ] >-< wfill ["First definition:", (showPos @occ1),"."] >-< wfill ["Type synonym :" , (showPos @nt),"."] pat = "DATA" >#< getName @nt >-< indent 2 ("|" >#< "...") >-< "TYPE" >#< getName @nt >#< "=" >#< "..." help = wfill ["A type synonym with name", getName @nt ,"has been given while there already is TYPE" ,"definition with the same name." ,"You should either rename or remove the type synonym." ] act = wfill [ "The clashing type synonym will be ignored." ] in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose | DupSet lhs.pp = let mesg = wfill ["Definition of nonterminal set", getName @name, "clashes with another" ,"set, a type synonym or a data definition." ] >-< wfill ["First definition:", (showPos @occ1),"."] >-< wfill ["Set definition:" , (showPos @name),"."] pat = "SET" >#< getName @name >#< "=" >#< "..." >-< "SET" >#< getName @name >#< "=" >#< "..." help = wfill ["A nonterminal set with name", getName @name ,"has been given while there already is a SET, DATA, or TYPE" ,"definition with the same name." ,"You should either rename or remove the nonterminal set." ] act = wfill [ "The clashing nonterminal set will be ignored." ] in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose | DupInhAttr lhs.pp = let mesg = wfill ["Repeated declaration of inherited attribute", getName @attr , "of nonterminal", getName @nt, "." ] >-< wfill ["First definition:", (showPos @occ1),"."] >-< wfill ["Other definition:", (showPos @attr),"."] pat = "ATTR" >#< getName @nt >#< "[" >#< getName @attr >|< ":...," >#< getName @attr >|< ":... | | ]" help = wfill ["The identifier" , getName @attr ,"has been declared" ,"as an inherited (or chained) attribute for nonterminal" ,getName @nt , "more than once, with possibly different types." ,"Delete all but one or rename them to make them unique." ] act = wfill ["One declaration with its corresponding type is considered valid." ,"All others have been discarded. The generated program will probably not run." ] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | DupSynAttr lhs.pp = let mesg = wfill ["Repeated declaration of synthesized attribute", getName @attr , "of nonterminal", getName @nt, "." ] >-< wfill ["First definition:", (showPos @occ1),"."] >-< wfill ["Other definition:", (showPos @attr),"."] pat = "ATTR" >#< getName @nt >#< "[ | |" >#< getName @attr >|< ":...," >#< getName @attr >|< ":... ]" help = wfill ["The identifier" , getName @attr ,"has been declared" ,"as a synthesized (or chained) attribute for nonterminal" ,getName @nt , "more than once, with possibly different types." ,"Delete all but one or rename them to make them unique." ] act = wfill ["One declaration with its corresponding type is considered valid." ,"All others have been discarded. The generated program will probably not run." ] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | DupChild lhs.pp = let mesg = wfill ["Repeated declaration for field", getName @name, "of alternative" ,getName @con, "of nonterminal", getName @nt, "." ] >-< wfill ["First definition:", (showPos @occ1),"."] >-< wfill ["Other definition:", (showPos @name),"."] pat = "DATA" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< (getName @name >|< ":..." >-< getName @name >|< ":...")) help = wfill ["The alternative" ,getName @con , "of nonterminal" ,getName @nt ,"has more than one field that is named" , getName @name ++ ". Possibly they have different types." ,"You should either rename or remove enough of them to make all fields of" ,getName @con , "for nonterminal " , getName @nt , "uniquely named." ] act = wfill ["The last declaration with its corresponding type is considered valid." ,"All others have been discarded." ] in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose | DupRule lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rules for" ,showAttrDef @field @attr,"." ] >-< wfill ["First rule:", (showPos @occ1),"."] >-< wfill ["Other rule:", (showPos @attr),"."] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt ,", there is more than one rule for the" , showAttrDef @field @attr ,". You should either rename or remove enough of them to make all rules for alternative" ,getName @con , "of nonterminal " ,getName @nt , "uniquely named." ] act = wfill ["The last rule given is considered valid. All others have been discarded."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | DupRuleName lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rule names for" ,show @nm,"." ] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...") >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...") help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt ,", there is more than one rule name " , show @nm ,". You should either rename or remove enough of them." ] act = wfill ["Compilation cannot continue."] in ppError (isError @lhs.options @me) (getPos @nm) mesg pat help act @lhs.verbose | DupSig lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more typesignatures for" ,showAttrDef _LOC @attr,"." ] >-< wfill ["First signature:", (showPos @attr),"."] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...") >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...") help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt ,", there is more than one rule for the" , showAttrDef _LOC @attr ,". You should remove enough of them to make all typesignatures for alternative" ,getName @con , "of nonterminal " ,getName @nt , "unique." ] act = wfill ["The last typesignature given is considered valid. All others have been discarded."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | UndefNont lhs.pp = let mesg = wfill ["Nonterminal", getName @nt, "is not defined." ] pat = "DATA" >#< getName @nt >#< "..." help = wfill ["There are attributes and/or rules for nonterminal" , getName @nt ,", but there is no definition" , "for" ,getName @nt, ". Maybe you misspelled it? Otherwise insert a definition." ] act = wfill ["Everything regarding the unknown nonterminal has been ignored."] in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose | UndefAlt lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt, "is not defined." ] pat = "DATA" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< "...") help = wfill ["There are rules for alternative", getName @con , "of nonterminal" ,getName @nt ,", but there is no definition for this alternative in the definitions of the" ,"nonterminal" , getName @nt, ". Maybe you misspelled it? Otherwise insert a definition." ] act = wfill ["All rules for the unknown alternative have been ignored."] in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose | UndefChild lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt , "does not have a nontrivial field named", getName @name , "." ] pat = "SEM" >#< @nt >-< indent 2 ("|" >#< getName @con >#< ppAttr @name (identifier "") >#< "= ...") help = wfill ["There are rules that define or use attributes of field" , getName @name ,"in alternative" , getName @con , "of nonterminal" , getName @nt ,", but there is no field with AG-type in the definition of the alternative." ,"Maybe you misspelled it? Otherwise insert the field into the definition," ,"or change its type from an HS-type to an AG-type." ] act = wfill ["All rules for the unknown field have been ignored."] in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose | MissingRule lhs.pp = let mesg = wfill ["Missing rule for", showAttrDef @field @attr , "in alternative" , getName @con , "of nonterminal",getName @nt ,"." ] pat = "SEM" >#< @nt >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") help = wfill ["The", showAttrDef @field @attr, "in alternative", getName @con , "of nonterminal", getName @nt, "is missing and cannot be inferred" ,"by a copy rule, so you should add an appropriate rule." ] act = wfill ["The value of the attribute has been set to undefined."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | MissingNamedRule lhs.pp = let mesg = wfill ["Missing rule name ", show @name , "in alternative" , getName @con , "of nonterminal",getName @nt ,"." ] pat = "SEM" >#< @nt >-< indent 2 ("|" >#< getName @con >#< show @name >#< ": ... = ...") help = wfill ["There is a dependency on a rule with name ", show @name , "in alternative" , getName @con , "of nonterminal",getName @nt ,", but no rule has been defined with this name. Maybe you misspelled it?" ] act = wfill ["Compilation cannot continue."] in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose | SuperfluousRule lhs.pp = let mesg = wfill ["Rule for non-existing", showAttrDef @field @attr , "at alternative" , getName @con , "of nonterminal",getName @nt, "." ] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") help = wfill ["There is a rule for" , showAttrDef @field @attr , "in the definitions for alternative" , getName @con ,"of nonterminal" , getName @nt, ", but this attribute does not exist. Maybe you misspelled it?" ,"Otherwise either remove the rule or add an appropriate attribute definition." ] act = wfill ["The rule has been ignored."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | UndefLocal lhs.pp = let mesg = wfill ["Undefined local variable or field",getName @var, "at constructor" , getName @con , "of nonterminal",getName @nt, "." ] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< ". = " >#< "..." >#< "@" >|< getName @var >#< "..." ) help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" , getName @nt , "contains a local variable or field name that is not defined. " ,"Maybe you misspelled it?" ,"Otherwise either remove the rule or add an appropriate definition." ] act = wfill ["The generated program will not run."] in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose | ChildAsLocal lhs.pp = let mesg = wfill ["Nontrivial field ",getName @var, "is used as local at constructor" , getName @con , "of nonterminal",getName @nt, "." ] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< "... = " >#< "..." >#< "@" >|< getName @var >#< "..." ) help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" , getName @nt , "contains a nontrivial field name", getName @var, "." ,"You should use @", getName @var, ".self instead, where self is a SELF-attribute." ] act = wfill ["The generated program probably contains a type error or has undefined variables."] in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose | UndefAttr lhs.pp = let mesg = wfill ["Undefined" , if @isOut then showAttrDef @field @attr else showAttrUse @field @attr , "at constructor" , getName @con , "of nonterminal",getName @nt, "." ] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< ". = " >#< "..." >#< ppAttrUse @field @attr >#< "...") help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" ,getName @nt , "contains an attribute that is not defined" ,"Maybe you misspelled it?" ,"Otherwise either remove the rule or add an appropriate attribute definition." ] act = wfill ["The generated program will not run."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | CyclicSet lhs.pp = let mesg = wfill ["Cyclic definition for nonterminal set", getName @name] pat = "SET" >#< getName @name >#< "=" >#< "..." >#< getName @name >#< "..." help = wfill ["The defintion for a nonterminal set named" , getName @name ,"directly or indirectly refers to itself." ,"Adapt the definition of the nonterminal set, to remove the cyclic dependency." ] act = wfill ["The nonterminal set", getName @name, "is considered to be empty."] in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose | Cyclic lhs.pp = let pos = getPos @nt mesg = text "Circular dependency for nonterminal" >#< getName @nt >#< ( case @mbCon of Nothing -> empty Just con -> text "and constructor" >#< con ) >#< ( case @verts of v : _ -> text "including vertex" >#< text v _ -> empty ) pat = text "cyclic rule definition" help = hlist (text "The following attributes are all cyclic: " : map text @verts) act = wfill ["code cannot be generated until the cycle is removed."] in ppError (isError @lhs.options @me) pos mesg pat help act False | CustomError lhs.pp = let pat = text "unknown" help = wfill ["not available."] act = wfill ["unknown"] in ppError (isError @lhs.options @me) @pos @mesg pat help act False | LocalCirc lhs.pp = let mesg = wfill ["Circular dependency for local attribute", getName @attr , "of alternative", getName @con, "of nonterminal", getName @nt] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< "loc." >|< getName @attr >#< "=" >#< "..." >#< "@loc." >|< getName @attr >#< "...") help = if null @path then text "the definition is directly circular" else hlist ("The following attributes are involved in the cycle:": @path) act | @o_visit = text "An unoptimized version was generated. It might hang when run." | otherwise = text "The generated program might hang when run." in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose | InstCirc lhs.pp = let mesg = wfill ["Circular dependency for inst attribute", getName @attr , "of alternative", getName @con, "of nonterminal", getName @nt] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< "inst." >|< getName @attr >#< "=" >#< "..." >#< "@s." >#< "...") help = if null @path then text "the definition is directly circular" else hlist ("The following attributes are involved in the cycle:": @path) act | @o_visit = text "An unoptimized version was generated. It might hang when run." | otherwise = text "The generated program might hang when run." in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose | DirectCirc lhs.pp = let mesg = wfill ["In nonterminal", getName @nt, "synthesized and inherited attributes are mutually dependent" ] >-< vlist (map showEdge @cyclic) pat = text "" help = vlist (map showEdgeLong @cyclic) act | @o_visit = text "An unoptimized version was generated. It might hang when run." | otherwise = text "The generated program might hang when run." in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose | InducedCirc lhs.pp = let mesg = wfill ["After scheduling, in nonterminal", getName @nt, "synthesized and inherited attributes have an INDUCED mutual dependency" ] >-< vlist (map showEdge @cyclic) pat = text "" showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (succ i :: Integer,("visit " ++ show i) : map ind (showsSegment c))) 0 segs)) help = vlist (("Interface for nonterminal " ++ getName @nt ++ ":") : map ind (showInter @cinter)) >-< vlist (map showEdgeLong @cyclic) act = text "An unoptimized version was generated. It might hang when run." in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose | MissingTypeSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC @attr , "in alternative" , getName @con , "of nonterminal",getName @nt ,"." ]>-< wfill ["Location:", (showPos @attr),"."] pat = "SEM" >#< @nt >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< ": ...") help = wfill ["The", showAttrDef _LOC @attr, "in alternative", getName @con ,"of nonterminal", getName @nt, "is needed in two separate visits to", getName @nt ,"so its type is needed to generate type signatures." ,"Please supply its type." ] act = wfill ["The type signatures of semantic functions are not generated."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | MissingInstSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST @attr , "in alternative" , getName @con , "of nonterminal",getName @nt ,"." ]>-< wfill ["Location:", (showPos @attr),"."] pat = "SEM" >#< @nt >-< indent 2 ("|" >#< getName @con >#< ppAttr _INST @attr >#< ": ...") help = wfill ["The", showAttrDef _INST @attr, "in alternative", getName @con ,"of nonterminal", getName @nt, "is a non-terminal attribute, so " ,"its type is needed to attribute its value." ,"Please supply its type." ] act = wfill ["It is not possible to proceed without this signature."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | MissingUnique lhs.pp = let mesg = wfill ["Missing unique counter (chained attribute)" , getName @attr , "at nonterminal" , getName @nt, "." ] pat = "ATTR" >#< getName @nt >#< "[ |" >#< getName @attr >#< " : ... | ]" help = wfill ["A unique attribute signature in a constructor for nonterminal" , getName @nt , "refers to an unique counter (chained attribute) named " , getName @attr ,"Maybe you misspelled it?" ,"Otherwise either remove the signature or add an appropriate attribute definition." ] act = wfill ["It is not possible to proceed without this declaration."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | DupUnique lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more unique-attribute signatures for" ,showAttrDef _LOC @attr,"." ] >-< wfill ["First signature:", (showPos @attr),"."] pat = "SEM" >#< getName @nt >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...") >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...") help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt ,", there is more than one unique-attribute signature for the" , showAttrDef _LOC @attr ,". You should remove enough of them to make all unique-signatures for alternative" ,getName @con , "of nonterminal " ,getName @nt , "unique." ] act = wfill ["Unpredicatable sharing of unique numbers may occur."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | MissingSyn lhs.pp = let mesg = wfill ["Missing synthesized attribute" , getName @attr , "at nonterminal" , getName @nt, "." ] pat = "ATTR" >#< getName @nt >#< "[ | | " >#< getName @attr >#< " : ... ]" help = wfill ["An augment rule for a constructor for nonterminal" , getName @nt , "refers to a synthesized attribute named " , getName @attr ,"Maybe you misspelled it?" ,"Otherwise add an appropriate attribute definition." ] act = wfill ["It is not possible to proceed without this declaration."] in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose | IncompatibleVisitKind lhs.pp = let mesg = "visit" >#< @vis >#< "of child" >#< @child >#< " with kind" >#< show @to >#< " cannot be called from a visit with kind " >#< show @from pat = empty help = empty act = text "It is not possible to proceed without fixing this kind error." in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose | IncompatibleRuleKind lhs.pp = let mesg = "rule" >#< @rule >#< "cannot be called from a visit with kind " >#< show @kind pat = empty help = empty act = text "It is not possible to proceed without fixing this kind error." in ppError (isError @lhs.options @me) (getPos @rule) mesg pat help act @lhs.verbose | IncompatibleAttachKind lhs.pp = let mesg = "child" >#< @child >#< "cannot be called from a visit with kind " >#< show @kind pat = empty help = empty act = text "It is not possible to proceed without fixing this kind error." in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose { toWidth :: Int -> String -> String toWidth n xs | k PP_Doc showEdge ((inh,syn),_,_) = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++ getName syn) showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc showEdgeLong ((inh,syn),path1,path2) = text ("inherited attribute " ++ getName inh ++ " is needed for " ++ "synthesized attribute " ++ getName syn) >-< indent 4 (vlist (map text path2)) >-< text "and back: " >-< indent 4 (vlist (map text path1)) attrText :: Identifier -> Identifier -> String attrText inh syn = if inh == syn then "threaded attribute " ++ getName inh else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn showLineNr :: Int -> String showLineNr i | i==(-1) = "CR" | otherwise = show i showAttrDef :: Identifier -> Identifier -> String showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a | f == _LOC = "local attribute " ++ getName a | f == _INST = "inst attribute " ++ getName a | otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f showAttrUse :: Identifier -> Identifier -> String showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a | f == _LOC = "local attribute " ++ getName a | f == _INST = "inst attribute " ++ getName a | otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f ppAttr :: Identifier -> Identifier -> PP_Doc ppAttr f a = text (getName f++"."++getName a) ppAttrUse :: Identifier -> Identifier -> PP_Doc ppAttrUse f a = "@" >|< ppAttr f a } -- Printing of error messages { infixr 5 +#+ (+#+) :: String -> String -> String (+#+) s t = s ++ " " ++ t infixr 5 +.+ (+.+) :: Identifier -> Identifier -> String (+.+) s t = getName s ++ "." ++ getName t wfill :: [String] -> PP_Doc wfill = fill . addSpaces. concat . map words where addSpaces (x:xs) = x:map addSpace xs addSpaces [] = [] addSpace [x] | x `elem` ".,;:!?" = [x] addSpace xs = ' ':xs ppError :: Bool -- class of the error, True:error False:warning -> Pos -- source position -> PP_Doc -- error message -> PP_Doc -- pattern -> PP_Doc -- help, more info -> PP_Doc -- action taken by AG -> Bool -- verbose? show help and action? -> PP_Doc ppError isErr pos mesg pat hlp act verb = let position = case pos of Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c | otherwise -> pp "uuagc" tp = if isErr then "error" else "warning" header = position >|< ":" >#< tp >|< ":" >#< mesg pattern = "pattern :" >#< pat help = "help :" >#< hlp action = "action :" >#< act in if verb then vlist [text "",header,pattern,help,action] else header {- -- old error reporting code = let cl = if isError then "ERROR" else "Warning" position = case pos of (Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c | otherwise -> empty header = "*** UU.AG" >#< cl >#< position >#< "***" message = "problem :" >#< mesg pattern = "pattern :" >#< pat help = "help :" >#< hlp action = "action :" >#< act in if verbose then vlist [text "",header,message,pattern,help,action] else vlist [text "",header,message] -} showPos :: Identifier -> String showPos = show . getPos ppInterface :: Show a => a -> PP_Doc ppInterface inter = wfill ["interface:", show inter] }