MODULE {Errs} {errsToStr, prettyErrs, Errs, Err(..), debugMsg, nullErrs} {}

PRAGMA genlinepragmas

imports
{
import Common
import Pretty
import UU.Scanner.Position
import Data.Sequence(Seq)
import qualified Data.Sequence as Seq
import Data.Map(Map)
import qualified Data.Map as Map
import Data.Foldable
import Opts
}

WRAPPER Err

{
type Errs = Seq Err

prettyErr :: Opts -> Err -> PP_Doc
prettyErr opts e
  = pp_Syn_Err syn
  where
    inh = Inh_Err { opts_Inh_Err = opts }
    syn = wrap_Err sem inh
    sem = sem_Err e

prettyErrs :: Opts -> Errs -> PP_Doc
prettyErrs opts = vlist . map (prettyErr opts) . toList

errsToStr :: Opts -> Errs -> String
errsToStr opts es = disp (prettyErrs opts es) 999999 ""

debugMsg :: String -> Errs
debugMsg = Seq.singleton . Err_General noPos

nullErrs :: Errs -> Bool
nullErrs = Seq.null
}

DATA Err
  | General
      pos     : Pos
      str     : String
  | Missing
      ks      : {[Ident]}
  | Dup
      ks      : {[Ident]}
  | ExpVisit
      pos     : Pos
      found   : Ident
      expect  : Ident
  | MissingVisit
      pos     : Pos
      child   : Ident
      visit   : Ident
  | VisitsNotImpl
      nonterm : {[Ident]}
      vs      : {[Ident]}
  | UndefVisit
      child   : Ident
      visit   : Ident
      visits  : {[Ident]}
  | UndeclVisit
      pos     : Pos
      name    : Ident
      itf     : Ident
  | UndetachVisit
      child   : Ident
      visit   : Ident
      expect  : Ident
  | UndeclAttr
      child   : Ident
      name    : Ident
  | NameClash
      name    : Ident
  | MissingAttr
      inherited : Bool
      child     : Ident
      name      : Ident
  | DupAttr
      inherited : Bool
      child     : Ident
      name      : Ident
  | MissingClause
      itf       : Ident
      name      : Ident
  | AmbAttach
      name      : Ident
      visit     : Ident
  | AmbDefault
      pos       : Pos
      name      : Ident
  | TypeConflict
      found     : Ident
      expect    : Ident
  | ChildSynUnav
      pos       : Pos
      child     : Ident
      itf       : Ident
      vis       : Ident
      name      : Ident
  | Cyclic
      pos       : Pos
      posMap    : {Map DepItem Pos}
      comps     : {[DepItem]}
  | MatchCyclic
      pos       : Pos
  | ClausesCyclic
      pos       : Pos
      name      : Ident
      n         : Int
  | EffCyclic
      pos       : Pos
  | VisExpCyclic
      name      : Ident
      child     : Ident
  | IterCyclic
      pos       : Pos
  | InternalInCyclic
      pos       : Pos
      name      : Ident

ATTR Err [ opts : Opts | | pp : {PP_Doc} ]

SEM Err
  | General        lhs.pp = locLine @pos @str
  | Missing        lhs.pp = locLine @loc.pos ("undefined identifier" >#< show @loc.main)
  | Dup            lhs.pp = locLine @loc.pos ("duplicate identifier" >#< show @loc.main)
  | ExpVisit       lhs.pp = locLine @pos     ("expecting visit" >#< show @expect >#< "found" >#< show @found)
  | MissingVisit   lhs.pp = locLine @pos     ("missing invoke of visit" >#< show @visit >#< "of child" >#< show @child)
  | VisitsNotImpl  lhs.pp = locLine @loc.pos ("missing visit" >#< show @loc.main >#< "for" >#< show (head @nonterm))
  | UndefVisit     lhs.pp = locLine @loc.pos ("undefined visit" >#< show @visit >#< "of child" >#< show @child)
  | UndeclVisit    lhs.pp = locLine @pos     ("undeclared visit" >#< show @name >#< "of interface" >#< show @itf)
  | UndetachVisit  lhs.pp = locLine @loc.pos ("undetachable visit" >#< show @visit >#< "of child" >#< show @child >|< ": expecting visit" >#< show @expect)
  | UndeclAttr     lhs.pp = locLine @loc.pos ("undeclared attr" >#< show @child >|< "." >|< show @name)
  | NameClash      lhs.pp = locLine @loc.pos ("name clash" >#< show @name)
  | MissingAttr    lhs.pp = locLine @loc.pos ("undefined" >#< @loc.type >#< "attr" >#< show @child >|< "." >|< show @name)
  | DupAttr        lhs.pp = locLine @loc.pos ("duplicate" >#< @loc.type >#< "attr" >#< show @child >|< "." >|< show @name)
  | MissingClause  lhs.pp = locLine @loc.pos ("missing clause " >#< show @name >#< "of" >#< show @itf)
  | AmbAttach      lhs.pp = locLine @loc.pos ("ambiguous attach of child" >#< show @name >#< "and visit" >#< show @visit)
  | AmbDefault     lhs.pp = locLine @pos     ("ambiguous default statement for" >#< show @name)
  | TypeConflict   lhs.pp = locLine @loc.pos ("type" >#< show @found >#< "does not match expected type" >#< show @expect)
  | ChildSynUnav   lhs.pp = locLine @pos     ("default for" >#< show @name >#< "requires unavailable attribute" >#< show @name >#< "of" >#< show @child >|< "'s visit" >#< show @vis)
  | Cyclic         lhs.pp = locLine @pos     ("cycle:" >#< hlist_sp (map @loc.ppDep @comps) )
  | MatchCyclic    lhs.pp = locLine @pos     ("match statement not allowed in cyclic visit")
  | ClausesCyclic  lhs.pp = locLine @pos     ("cyclic visit" >#< show @name >#< "must have one clause, but has" >#< show @n)
  | EffCyclic      lhs.pp = locLine @pos     ("effectful code not allowed for cyclic stmt")
  | VisExpCyclic   lhs.pp = locLine @loc.pos ("visit" >#< show @name >#< "of" >#< show @child >#< "is on a cycle")
  | IterCyclic     lhs.pp = locLine @pos     ("visit may not be iterated by cyclic stmt")
  | InternalInCyclic  lhs.pp = locLine @pos  ("internal visit" >#< show @name >#< "may not occur in a fully cyclic visit")

SEM Err
  | Missing Dup
      loc.main   = if null @ks then ident "<unspecified>" else head @ks
      loc.others = tail @ks
      loc.pos    = identPos @loc.main
  | VisitsNotImpl
      loc.main   = if null @vs then ident "<unspecified>" else head @vs
      loc.others = tail @vs
      loc.pos    = identPos (head @nonterm)
  | UndefVisit
      loc.pos    = identPos @visit
  | UndetachVisit
      loc.pos    = identPos @visit
  | UndeclAttr
      loc.pos    = identPos @name
  | NameClash
      loc.pos    = identPos @name
  | MissingAttr
      loc.pos    = identPos @name
      loc.type   = if @inherited then text "inh" else text "syn"
  | DupAttr
      loc.pos    = identPos @name
      loc.type   = if @inherited then text "inh" else text "syn"
  | MissingClause
      loc.pos    = identPos @name
  | AmbAttach
      loc.pos    = identPos @name
  | TypeConflict
      loc.pos    = identPos @found
  | VisExpCyclic
      loc.pos    = identPos @name
  | Cyclic
      loc.ppDep  = \d -> let pos = Map.findWithDefault noPos d @posMap
                         in case d of
                              DepMatch _               -> "@" >|< show (line pos)
                              DepAssert _              -> "@" >|< show (line pos)
                              DepDefault o             -> "d" >|< show o
                              DepAttach n              -> "@" >|< show (line pos)
                              DepInvoke (visit:name:_) -> show name >|< "." >|< show visit >|< "@" >|< show (line $ identPos name)
                              DepInvoke _              -> text "i???"
                              DepVisStart (visit:_)    -> ">" >|< show visit >|< "@" >|< show (line $ identPos visit)
                              DepVisStart _            -> text ">v???"
                              DepVisEnd  (visit:_)     -> show visit >|< "@" >|< show (line $ identPos visit) >|< "<"
                              DepVisEnd _              -> text "<v???"
                              DepClause (clause:_)     -> "|" >|< show clause >|< "@" >|< show (line $ identPos clause)
                              DepClause _              -> text "|???"

{
locLine :: PP a => Pos -> a -> PP_Doc
locLine (Pos l c f) d
  = pp f >|< ":" >|< pp l >|< "," >|< pp c >|< ":error:" >#< pp d
}