ghc/compiler/hsSyn/HsCore.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[HsCore]{Core-syntax unfoldings in Haskell interface files}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
  11 @TyVars@ as well.  Currently trying the former... MEGA SIGH.
  12
  13 \begin{code}
  14 module HsCore (
  15         UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
  16         UfBinding(..), UfCon(..)
  17     ) where
  18
  19 #include "HsVersions.h"
  20
  21 -- friends:
  22 import HsTypes          ( HsType, pprParendHsType )
  23
  24 -- others:
  25 import Const            ( Literal )
  26 import Type             ( Kind )
  27 import CostCentre
  28 import Outputable
  29 \end{code}
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsection[HsCore-types]{Types for read/written Core unfoldings}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 \begin{code}
  38 data UfExpr name
  39   = UfVar       name
  40   | UfType      (HsType name)
  41   | UfCon       (UfCon name) [UfExpr name]
  42   | UfTuple     name [UfExpr name]              -- Type arguments omitted
  43   | UfLam       (UfBinder name)   (UfExpr name)
  44   | UfApp       (UfExpr name) (UfExpr name)
  45   | UfCase      (UfExpr name) name [UfAlt name]
  46   | UfLet       (UfBinding name)  (UfExpr name)
  47   | UfNote      (UfNote name) (UfExpr name)
  48
  49 data UfNote name = UfSCC CostCentre
  50                  | UfCoerce (HsType name)
  51                  | UfInlineCall
  52
  53 type UfAlt name = (UfCon name, [name], UfExpr name)
  54
  55 data UfCon name = UfDefault
  56                 | UfDataCon name
  57                 | UfLitCon Literal
  58                 | UfLitLitCon FAST_STRING (HsType name)
  59                 | UfPrimOp name
  60                 | UfCCallOp FAST_STRING    -- callee
  61                             Bool           -- True => dynamic (first arg is fun. pointer)
  62                             Bool           -- True <=> casm, rather than ccall
  63                             Bool           -- True <=> might cause GC
  64
  65 data UfBinding name
  66   = UfNonRec    (UfBinder name)
  67                 (UfExpr name)
  68   | UfRec       [(UfBinder name, UfExpr name)]
  69
  70 data UfBinder name
  71   = UfValBinder name (HsType name)
  72   | UfTyBinder  name Kind
  73 \end{code}
  74
  75
  76 %************************************************************************
  77 %*                                                                      *
  78 \subsection[HsCore-print]{Printing Core unfoldings}
  79 %*                                                                      *
  80 %************************************************************************
  81
  82 \begin{code}
  83 instance Outputable name => Outputable (UfExpr name) where
  84     ppr (UfVar v) = ppr v
  85     ppr (UfType ty) = char '@' <+> pprParendHsType ty
  86
  87     ppr (UfCon c as)
  88       = hsep [text "UfCon", ppr c, ppr as]
  89
  90     ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
  91
  92     ppr (UfLam b body)
  93       = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
  94
  95     ppr (UfApp fun arg) = ppr fun <+> ppr arg
  96
  97     ppr (UfCase scrut bndr alts)
  98       = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
  99               braces (hsep (punctuate semi (map pp_alt alts)))]
 100       where
 101         pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
 102
 103         ppr_arrow = ptext SLIT("->")
 104
 105     ppr (UfLet (UfNonRec b rhs) body)
 106       = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
 107     ppr (UfLet (UfRec pairs) body)
 108       = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
 109       where
 110         pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
 111
 112     ppr (UfNote note body)
 113       = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
 114
 115 instance Outputable name => Outputable (UfCon name) where
 116     ppr UfDefault       = text "DEFAULT"
 117     ppr (UfDataCon d)   = ppr d
 118     ppr (UfPrimOp p)    = ppr p
 119     ppr (UfCCallOp str is_dyn is_casm can_gc)
 120       = hcat [before, ptext str, after]
 121       where
 122             before = (if is_dyn then ptext SLIT("_dyn_") else empty) <>
 123                      ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
 124             after  = if is_casm then text "'' " else space
 125
 126 instance Outputable name => Outputable (UfBinder name) where
 127     ppr (UfValBinder name ty)  = hsep [ppr name, dcolon, ppr ty]
 128     ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
 129 \end{code}
 130