--
-- Desugars and checks occurrences of identifiers
--

MODULE {Desugar} {desugar} {}

PRAGMA genlinepragmas

INCLUDE "FlatAst.ag"

optpragmas
{ {-# OPTIONS -XTypeOperators -XEmptyDataDecls #-} }

imports
{
import Common
import Type
import UU.Scanner.Position
import Flat
import qualified Simple as S
import Data.Sequence(Seq)
import qualified Data.Sequence as Seq
import Error
import qualified Data.Map as Map
import Data.Map(Map)
import qualified Data.Set as Set
import Data.Set(Set)
import SymbolTable
import Data.Monoid



import Debug.Trace
}

WRAPPER Fag

{
desugar :: Fag -> Either Errs S.Sag
desugar ast = if Seq.null $ errs_Syn_Fag syn
              then Right $ fag_Syn_Fag syn
              else Left $ errs_Syn_Fag syn
  where
    inh = Inh_Fag {}
    sem = sem_Fag ast
    syn = wrap_Fag sem inh
}


ATTR Fag [ | | fag : {S.Sag} ]

SEM Fag
  | Ag
      lhs.fag  = (error $ show (@loc.tblFin, @loc.finInfos)) -- S.Sag_Ag [] [] []


--
-- Namespaces and scoping
--

{
data SpGeneral

type NmSpaces = Spaces (SpGeneral :+ End) Key

data Key
  = NoKey
  deriving (Eq, Ord, Show)

spGeneral :: SpaceId SpGeneral
spGeneral = SpaceId
}

ATTR Datas Data Cons Con FieldSigs FieldSig InhSigs InhSig SynSigs SynSig
     Itfs Itf Ctxs Ctx MaybeTail Tail Blocks MaybeBlock Block
     Codes Code Clauses Clause Defs Def MergeInfo Pats Pat
  [ spaces : NmSpaces | | ]

SEM Fag | Ag     loc.spaces = initialSpaces


--
-- Symbol table data types
--

{
data CatData = CatData
data CatCon  = CatCon
data CatVar  = CatVar
data CatFld  = CatFld
data CatItf  = CatItf
data CatInh  = CatInh
data CatSyn  = CatSyn
data CatCtx  = CatCtx


-- root
type TblType = TTCatData

type TTCatData = CatData :@ SubTbl
                    TblTypeDatas ()
                 :+ TTCatItf

type TTCatItf = CatItf :@ SubTbl
                   TblTypeItfs ()
                :+ End

-- datas
type TblTypeDatas = TTCatCon

type TTCatCon = CatCon :@ SubTbl
                  TblTypeCons ()
                :+ TTCatDataVar

type TTCatDataVar = CatVar :@ SubTbl
                       TblTypeVars ()
                    :+ End

-- constructors
type TblTypeCons = TTCatFld

type TTCatFld    = CatFld :@ SubTbl
                     TblTypeFields Type
                   :+ End
type TblTypeFields = End
type TblTypeVars   = End


-- itfs
type TblTypeItfs = TTCatItfVar

type TTCatItfVar = CatVar :@ SubTbl
                     TblTypeVars Int
                   :+ TTCatInh

type TTCatInh    = CatInh :@ SubTbl
                     TblTypeInhs Type
                   :+ TTCatCtx

type TTCatCtx    = CatCtx :@ SubTbl
                      TblTypeCtxs MaybeTail
                   :+ End

type TblTypeInhs = End
type TblTypeSyns = End

-- itf ctxs
type TblTypeCtxs = CatSyn :@ SubTbl
                     TblTypeSyns Type
                   :+ End


-- boilerplate
type TblGath = TableGath Item Key TblType
type TblFin  = TableFin Item Key TblType
type TblRef t a = ItemRef Item Key t a TblType
type TblPath t  = Path Item Key t TblType
type SubTbl t a = InfoMap Item Key Ident t a

catData :: TblPath TblType -> TblPath TTCatData
catData = catSkip0

catCon :: TblPath TblTypeDatas -> TblPath TTCatCon
catCon  = catSkip0

catDataVar :: TblPath TblTypeDatas -> TblPath TTCatDataVar
catDataVar  = catSkip1

catFld :: TblPath TblTypeCons -> TblPath TTCatFld
catFld  = catSkip0

catItf :: TblPath TblType -> TblPath TTCatItf
catItf  = catSkip1

catItfVar = catSkip0
catInh  = catSkip1
catCtx  = catSkip2
catSyn  = catSkip0
}


--
-- Chained attribute through all mayor NTs
--

ATTR Datas Data Cons Con FieldSigs FieldSig InhSigs InhSig SynSigs SynSig
     Itfs Itf Ctxs Ctx MaybeTail Tail Blocks MaybeBlock Block
     Codes Code Clauses Clause Defs Def MergeInfo Pats Pat
  [ tblFin : TblFin | tblGath : TblGath | ]

SEM Fag
  | Ag
      datas.tblGath = tblGathEmpty
      (loc.tblFin, loc.finInfos) = finalize @datas.tblGath


--
-- Paths and references
--

ATTR Datas Data [ rootPath : {TblPath TTCatData} | | ]
ATTR Cons Con [ dataPath : {TblPath TTCatCon} | | ]
ATTR FieldSigs FieldSig [ conPath : {TblPath TTCatFld} | | ]
ATTR Itfs Itf [ rootPath : {TblPath TTCatItf} | | ]
ATTR Ctxs Ctx [ itfPath : {TblPath TTCatCtx} | | ]
ATTR InhSigs InhSig [ itfPath : {TblPath TTCatInh} | | ]

SEM Fag | Ag        loc.root : {TblPath TblType}
                    loc.root = emptyPath
                    datas.rootPath = @loc.root .@ CatData
                    itfs.rootPath  = @loc.root .@ CatItf
SEM Data | Data     loc.dataInfo   = Item_Data (identPos @name) @name
                    loc.dataRef : {TblRef TblTypeDatas ()}
                    loc.dataRef    = @lhs.rootPath .! (@name, @loc.dataInfo)
                    cons.dataPath  = @loc.dataRef .@ CatCon
SEM Con | Con       loc.conInfo    = Item_Con (identPos @name) @name
                    loc.conRef     = @lhs.dataPath .! (@name, @loc.conInfo)
                    sigs.conPath   = @loc.conRef .@ CatFld
SEM FieldSig | Sig  loc.fieldInfo  = Item_Field (identPos @name) @name
                    loc.fieldRef   = @lhs.conPath .! (@name, @loc.fieldInfo)
SEM Itf | Itf       loc.itfInfo    = Item_Itf (identPos @name) @name
                    loc.itfRef     = @lhs.rootPath .! (@name, @loc.itfInfo)
                    inhs.itfPath   = @loc.itfRef .@ CatInh
                    ctxs.itfPath   = @loc.itfRef .@ CatCtx
SEM InhSig | Sig    loc.fieldInfo  = Item_Field (identPos @name) @name
                    loc.fieldRef   = @lhs.itfPath .! (@name, @loc.fieldInfo)
SEM Ctx | Ctx       loc.ctxInfo    = Item_Ctx (identPos @name) @name
                    loc.ctxRef     = @lhs.itfPath .! (@name, @loc.ctxInfo)

--
-- Analysis
--

SEM Data
  | Data
      loc.gath1 = stmt ( defValue @loc.dataRef (@lhs.spaces <! spGeneral) () @loc.dataInfo ) @lhs.tblGath
      loc.gath2 = stmt ( mapM_ (\ident -> defValue (typevarRef @loc.dataRef ident)
                                                   (@lhs.spaces <! spGeneral) () (typevarInfo ident)) @vars ) @loc.gath1
      cons.tblGath = @loc.gath2

{
typevarRef :: TblRef TblTypeDatas () -> Ident -> TblRef TblTypeVars ()
typevarRef dataRef ident = path .! (ident, typevarInfo ident)
  where path = dataRef .@ CatVar

typevarInfo :: Ident -> Item
typevarInfo ident = Item_TypeVar (identPos ident) ident
}

SEM Con
  | Con
      sigs.tblGath = stmt ( defValue @loc.conRef (@lhs.spaces <! spGeneral) () @loc.conInfo ) @lhs.tblGath

SEM FieldSig
  | Sig
      lhs.tblGath = stmt ( defValue @loc.fieldRef (@lhs.spaces <! spGeneral) @tp @loc.fieldInfo ) @lhs.tblGath

SEM Itf
  | Itf
      loc.gath1    = 
      inhs.tblGath = @loc.gath1


--
-- Collect errors
--

ATTR Fag [ | | errs USE {Seq.><} {Seq.empty} : Errs ]