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(..), UfConAlt(..),
  17         HsIdInfo(..), HsStrictnessInfo(..),
  18         IfaceSig(..), UfRuleBody(..)
  19     ) where
  20
  21 #include "HsVersions.h"
  22
  23 -- friends:
  24 import HsTypes          ( HsType, pprParendHsType )
  25
  26 -- others:
  27 import IdInfo           ( ArityInfo, UpdateInfo, InlinePragInfo )
  28 import CoreSyn          ( CoreBndr, CoreExpr )
  29 import Demand           ( Demand )
  30 import Literal          ( Literal )
  31 import PrimOp           ( CCall, pprCCallOp )
  32 import Type             ( Kind )
  33 import PprType          ( {- instance Outputable Type -} )
  34 import CostCentre
  35 import SrcLoc           ( SrcLoc )
  36 import Outputable
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection[HsCore-types]{Types for read/written Core unfoldings}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 \begin{code}
  46 data UfExpr name
  47   = UfVar       name
  48   | UfType      (HsType name)
  49   | UfTuple     name [UfExpr name]              -- Type arguments omitted
  50   | UfLam       (UfBinder name)   (UfExpr name)
  51   | UfApp       (UfExpr name) (UfExpr name)
  52   | UfCase      (UfExpr name) name [UfAlt name]
  53   | UfLet       (UfBinding name)  (UfExpr name)
  54   | UfNote      (UfNote name) (UfExpr name)
  55   | UfLit       Literal
  56   | UfLitLit    FAST_STRING (HsType name)
  57   | UfCCall     CCall (HsType name)
  58
  59 data UfNote name = UfSCC CostCentre
  60                  | UfCoerce (HsType name)
  61                  | UfInlineCall
  62                  | UfInlineMe
  63
  64 type UfAlt name = (UfConAlt name, [name], UfExpr name)
  65
  66 data UfConAlt name = UfDefault
  67                    | UfDataAlt name
  68                    | UfLitAlt Literal
  69                    | UfLitLitAlt FAST_STRING (HsType name)
  70
  71 data UfBinding name
  72   = UfNonRec    (UfBinder name)
  73                 (UfExpr name)
  74   | UfRec       [(UfBinder name, UfExpr name)]
  75
  76 data UfBinder name
  77   = UfValBinder name (HsType name)
  78   | UfTyBinder  name Kind
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection[HsCore-print]{Printing Core unfoldings}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89 instance Outputable name => Outputable (UfExpr name) where
  90     ppr (UfVar v) = ppr v
  91     ppr (UfLit l) = ppr l
  92
  93     ppr (UfLitLit l ty) = ppr l
  94     ppr (UfCCall cc ty) = pprCCallOp cc
  95
  96     ppr (UfType ty) = char '@' <+> pprParendHsType ty
  97
  98     ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
  99
 100     ppr (UfLam b body)
 101       = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
 102
 103     ppr (UfApp fun arg) = ppr fun <+> ppr arg
 104
 105     ppr (UfCase scrut bndr alts)
 106       = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
 107               braces (hsep (punctuate semi (map pp_alt alts)))]
 108       where
 109         pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
 110
 111         ppr_arrow = ptext SLIT("->")
 112
 113     ppr (UfLet (UfNonRec b rhs) body)
 114       = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
 115     ppr (UfLet (UfRec pairs) body)
 116       = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
 117       where
 118         pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
 119
 120     ppr (UfNote note body)
 121       = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
 122
 123 instance Outputable name => Outputable (UfConAlt name) where
 124     ppr UfDefault          = text "DEFAULT"
 125     ppr (UfLitAlt l)       = ppr l
 126     ppr (UfLitLitAlt l ty) = ppr l
 127     ppr (UfDataAlt d)      = ppr d
 128
 129 instance Outputable name => Outputable (UfBinder name) where
 130     ppr (UfValBinder name ty)  = hsep [ppr name, dcolon, ppr ty]
 131     ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection{Signatures in interface files}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 data IfaceSig name
 143   = IfaceSig    name
 144                 (HsType name)
 145                 [HsIdInfo name]
 146                 SrcLoc
 147
 148 instance (Outputable name) => Outputable (IfaceSig name) where
 149     ppr (IfaceSig var ty info _)
 150       = hang (hsep [ppr var, dcolon])
 151              4 (ppr ty $$ ifPprDebug (vcat (map ppr info)))
 152
 153 data HsIdInfo name
 154   = HsArity             ArityInfo
 155   | HsStrictness        HsStrictnessInfo
 156   | HsUnfold            InlinePragInfo (UfExpr name)
 157   | HsUpdate            UpdateInfo
 158   | HsSpecialise        (UfRuleBody name)
 159   | HsNoCafRefs
 160   | HsCprInfo
 161   | HsWorker            name            -- Worker, if any
 162
 163 instance Outputable name => Outputable (HsIdInfo name) where
 164   ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf
 165   ppr other            = empty  -- Havn't got around to this yet
 166
 167 data HsStrictnessInfo
 168   = HsStrictnessInfo ([Demand], Bool)
 169   | HsBottom
 170 \end{code}
 171
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection{Rules in interface files}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 \begin{code}
 180 data UfRuleBody name = UfRuleBody   FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name)     -- Pre typecheck
 181                      | CoreRuleBody FAST_STRING [CoreBndr]      [CoreExpr]    CoreExpr          -- Post typecheck
 182 \end{code}