ghc/compiler/coreSyn/AnnCoreSyn.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[AnnCoreSyntax]{Annotated core syntax}
   5
   6 For when you want @CoreSyntax@ trees annotated at every node.  Other
   7 than that, just like @CoreSyntax@.  (Important to be sure that it {\em
   8 really is} just like @CoreSyntax@.)
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module AnnCoreSyn (
  14         AnnCoreBinding(..), SYN_IE(AnnCoreExpr),
  15         AnnCoreExpr'(..),       -- v sad that this must be exported
  16         AnnCoreCaseAlts(..), AnnCoreCaseDefault(..),
  17
  18         deAnnotate -- we may eventually export some of the other deAnners
  19     ) where
  20
  21 IMP_Ubiq(){-uitous-}
  22
  23 import CoreSyn
  24
  25 import Id         ( SYN_IE(Id) )
  26 import Literal    ( Literal )
  27 import PrimOp     ( PrimOp )
  28 import CostCentre ( CostCentre )
  29 import Type       ( GenType )
  30
  31 \end{code}
  32
  33 \begin{code}
  34 data AnnCoreBinding val_bdr val_occ tyvar uvar annot
  35   = AnnNonRec val_bdr (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
  36   | AnnRec    [(val_bdr, AnnCoreExpr val_bdr val_occ tyvar uvar annot)]
  37 \end{code}
  38
  39 \begin{code}
  40 type AnnCoreExpr val_bdr val_occ tyvar uvar annot
  41   = (annot, AnnCoreExpr' val_bdr val_occ tyvar uvar annot)
  42
  43 data AnnCoreExpr' val_bdr val_occ tyvar uvar annot
  44   = AnnVar      val_occ
  45   | AnnLit      Literal
  46
  47   | AnnCon      Id     [GenCoreArg val_occ tyvar uvar]
  48   | AnnPrim     PrimOp [GenCoreArg val_occ tyvar uvar]
  49
  50   | AnnLam      (GenCoreBinder val_bdr tyvar uvar)
  51                 (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
  52
  53   | AnnApp      (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
  54                 (GenCoreArg  val_occ tyvar uvar)
  55
  56   | AnnCase     (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
  57                 (AnnCoreCaseAlts val_bdr val_occ tyvar uvar annot)
  58
  59   | AnnLet      (AnnCoreBinding val_bdr val_occ tyvar uvar annot)
  60                 (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
  61
  62   | AnnSCC      CostCentre
  63                 (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
  64
  65   | AnnCoerce   Coercion
  66                 (GenType tyvar uvar)
  67                 (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
  68 \end{code}
  69
  70 \begin{code}
  71 data AnnCoreCaseAlts val_bdr val_occ tyvar uvar annot
  72   = AnnAlgAlts  [(Id,
  73                   [val_bdr],
  74                   AnnCoreExpr val_bdr val_occ tyvar uvar annot)]
  75                 (AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot)
  76   | AnnPrimAlts [(Literal,
  77                   AnnCoreExpr val_bdr val_occ tyvar uvar annot)]
  78                 (AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot)
  79
  80 data AnnCoreCaseDefault val_bdr val_occ tyvar uvar annot
  81   = AnnNoDefault
  82   | AnnBindDefault  val_bdr
  83                     (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
  84 \end{code}
  85
  86 \begin{code}
  87 deAnnotate :: AnnCoreExpr val_bdr val_occ tyvar uvar ann
  88            -> GenCoreExpr val_bdr val_occ tyvar uvar
  89
  90 deAnnotate (_, AnnVar   v)          = Var v
  91 deAnnotate (_, AnnLit   lit)        = Lit lit
  92 deAnnotate (_, AnnCon   con args)   = Con con args
  93 deAnnotate (_, AnnPrim  op args)    = Prim op args
  94 deAnnotate (_, AnnLam   binder body)= Lam binder (deAnnotate body)
  95 deAnnotate (_, AnnApp   fun arg)    = App (deAnnotate fun) arg
  96 deAnnotate (_, AnnSCC   lbl body)   = SCC lbl (deAnnotate body)
  97 deAnnotate (_, AnnCoerce c ty body) = Coerce c ty (deAnnotate body)
  98
  99 deAnnotate (_, AnnLet bind body)
 100   = Let (deAnnBind bind) (deAnnotate body)
 101   where
 102     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 103     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 104
 105 deAnnotate (_, AnnCase scrut alts)
 106   = Case (deAnnotate scrut) (deAnnAlts alts)
 107   where
 108     deAnnAlts (AnnAlgAlts alts deflt)
 109       = AlgAlts [(con,args,deAnnotate rhs) | (con,args,rhs) <- alts]
 110                  (deAnnDeflt deflt)
 111
 112     deAnnAlts (AnnPrimAlts alts deflt)
 113       = PrimAlts [(lit,deAnnotate rhs) | (lit,rhs) <- alts]
 114                    (deAnnDeflt deflt)
 115
 116     deAnnDeflt AnnNoDefault             = NoDefault
 117     deAnnDeflt (AnnBindDefault var rhs) = BindDefault var (deAnnotate rhs)
 118 \end{code}