uuagc-0.9.50: src-ag/SemHsTokens.ag

INCLUDE "HsToken.ag"

imports
{
import qualified Data.Sequence as Seq
import Data.Sequence(Seq,empty,singleton,(><))
import Data.Foldable(toList)
import Pretty

import TokenDef
import HsToken
import ErrorMessages
}

ATTR HsTokensRoot
     [
     | |
       errors    USE {Seq.><} {Seq.empty}:{Seq Error}
       usedLocals:{[Identifier]}
       usedAttrs :{[(Identifier,Identifier)]}
       textLines  :{[String]}
       usedFields:{[Identifier]}
     ]

-------------------------------------------------------------------------------
--  Context information
-------------------------------------------------------------------------------
ATTR HsTokensRoot
     HsTokens HsToken [ nt,con    : {Identifier}
                        allfields : {[(Identifier,Type,ChildKind)]}
                        allnts    : {[Identifier]}
                        attrs     : {[(Identifier,Identifier)]}
                        options   : {Options}
                      ||
                      ]

ATTR HsTokens HsToken [ fieldnames : {[Identifier]} | | ]
SEM HsTokensRoot
  | HsTokensRoot tokens.fieldnames = map (\(n,_,_) -> n) @lhs.allfields

-------------------------------------------------------------------------------
--  Errors
-------------------------------------------------------------------------------
ATTR HsTokens HsToken [ | |  errors USE {Seq.><} {Seq.empty}:{Seq Error}  ]

-------------------------------------------------------------------------------
-- Syntax errors
-------------------------------------------------------------------------------

SEM HsToken
  | Err lhs.errors = let m = text @mesg
                     in Seq.singleton (CustomError False @pos m)

-------------------------------------------------------------------------------
--  Undefined variables
-------------------------------------------------------------------------------

{
isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts
isNTname allnts _                  = False
}


-- An AGLocal is either a local variable or a terminal
SEM HsToken
  | AGLocal   loc.tkAsLocal = AGLocal @var @pos @rdesc        -- refers to the terminal
              loc.tkAsField = AGField _LOC @var @pos @rdesc   -- refers to the (local) attribute
              loc.(errors,output,tok,usedLocals) =
                     if @var `elem` @lhs.fieldnames   -- check if @var occurs as a terminal
                     then if  isNTname @lhs.allnts (lookup @var (map (\(n,t,_) -> (n,t)) @lhs.allfields))
                          then (Seq.singleton(ChildAsLocal @lhs.nt @lhs.con @var), @loc.tkAsLocal,(@pos,fieldname @var), []    )
                          else (Seq.empty, @loc.tkAsLocal, (@pos,fieldname @var), []    )
                     else if (_LOC,@var) `elem` @lhs.attrs
                          then (Seq.empty                                      , @loc.tkAsField, (@pos,locname @lhs.options @var), [@var])
                          else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @lhs.options @var), []    )

SEM HsToken
  | AGField   lhs.errors = if (@field,@attr) `elem` @lhs.attrs
                           then Seq.empty
                           else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames))
                                then Seq.singleton (UndefChild @lhs.nt @lhs.con @field)
                                else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False)

-------------------------------------------------------------------------------
--         Used variables
-------------------------------------------------------------------------------

ATTR HsTokens HsToken [ | | usedLocals USE {++} {[]} : {[Identifier]}
                            usedAttrs  USE {++} {[]} : {[(Identifier,Identifier)]} ]

SEM HsToken
  | AGField (lhs.usedAttrs,lhs.usedLocals)
              = if @field == _LOC
                then ([], [@attr])
                else ([(@field,@attr)], [])


-------------------------------------------------------------------------------
--         Used fields
-------------------------------------------------------------------------------
ATTR HsTokens HsToken [ | | usedFields USE {Seq.><} {Seq.empty} : {Seq Identifier} ]

SEM HsToken
  | AGLocal lhs.usedFields = if @var `elem` @lhs.fieldnames
                              then Seq.singleton @var
                              else Seq.empty
SEM HsTokensRoot
  | HsTokensRoot lhs.usedFields = toList @tokens.usedFields

-------------------------------------------------------------------------------
--  Pretty printing
-------------------------------------------------------------------------------

SEM HsTokensRoot
  | HsTokensRoot lhs.textLines = showTokens @tokens.tks

SEM HsTokens [ || tks : {[(Pos,String)]} ]
  | Cons lhs.tks = @hd.tok : @tl.tks
  | Nil  lhs.tks = []

SEM HsToken [ || tok:{(Pos,String)}]
   | AGField
       loc.addTrace = case @rdesc of
                        Just d  -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"
                        Nothing -> id
       lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)

   | HsToken lhs.tok = (@pos, @value)

   | CharToken lhs.tok = (@pos, if null @value
                                   then ""
                                   else showCharShort (head @value)
                         )

   | StrToken  lhs.tok = (@pos, showStrShort @value)
   | Err       lhs.tok = (@pos, "")

-------------------------------------------------------------------------------
--  Desugar (resolve AGLocals to explicit AGFields)
-------------------------------------------------------------------------------

ATTR HsTokensRoot [ | | output : {[HsToken]} ]
ATTR HsTokens HsToken [ | | output : SELF ]