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