ghc/compiler/parser/ParserCore.y

   1 {
   2 module ParserCore ( parseCore ) where
   3
   4 import ForeignCall
   5
   6 import HsCore
   7 import RdrHsSyn
   8 import HsSyn
   9 import TyCon
  10 import TcType
  11 import RdrName
  12 import OccName
  13 import Module
  14 import ParserCoreUtils
  15 import LexCore
  16 import Literal
  17 import BasicTypes
  18 import Type
  19 import SrcLoc
  20 import PrelNames
  21 import FastString
  22 import Outputable
  23
  24 #include "../HsVersions.h"
  25
  26 }
  27
  28 %name parseCore
  29 %tokentype { Token }
  30
  31 %token
  32  '%module'      { TKmodule }
  33  '%data'        { TKdata }
  34  '%newtype'     { TKnewtype }
  35  '%forall'      { TKforall }
  36  '%rec'         { TKrec }
  37  '%let'         { TKlet }
  38  '%in'          { TKin }
  39  '%case'        { TKcase }
  40  '%of'          { TKof }
  41  '%coerce'      { TKcoerce }
  42  '%note'        { TKnote }
  43  '%external'    { TKexternal }
  44  '%_'           { TKwild }
  45  '('            { TKoparen }
  46  ')'            { TKcparen }
  47  '{'            { TKobrace }
  48  '}'            { TKcbrace }
  49  '#'            { TKhash}
  50  '='            { TKeq }
  51  '::'           { TKcoloncolon }
  52  '*'            { TKstar }
  53  '->'           { TKrarrow }
  54  '\\'           { TKlambda}
  55  '@'            { TKat }
  56  '.'            { TKdot }
  57  '?'            { TKquestion}
  58  ';'            { TKsemicolon }
  59  NAME           { TKname $$ }
  60  CNAME          { TKcname $$ }
  61  INTEGER        { TKinteger $$ }
  62  RATIONAL       { TKrational $$ }
  63  STRING         { TKstring $$ }
  64  CHAR           { TKchar $$ }
  65
  66 %monad { P } { thenP } { returnP }
  67 %lexer { lexer } { TKEOF }
  68
  69 %%
  70
  71 module  :: { RdrNameHsModule }
  72         : '%module' modid tdefs vdefgs
  73                 { HsModule (Just (mkHomeModule $2)) Nothing
  74                            [] ($3 ++ concat $4) Nothing noSrcLoc}
  75
  76 tdefs   :: { [RdrNameHsDecl] }
  77         : {- empty -}   {[]}
  78         | tdef ';' tdefs        {$1:$3}
  79
  80 tdef    :: { RdrNameHsDecl }
  81         : '%data' q_tc_name tbinds '=' '{' cons1 '}'
  82                 { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
  83         | '%newtype' q_tc_name tbinds trep
  84                 { TyClD (mkTyData NewType ([], $2, $3) ($4 $2) Nothing noSrcLoc) }
  85
  86 -- For a newtype we have to invent a fake data constructor name
  87 -- It doesn't matter what it is, because it won't be used
  88 trep    :: { (RdrName -> DataConDetails (ConDecl RdrName)) }
  89         : {- empty -}   { (\ tc_name -> Unknown) }
  90         | '=' ty        { (\ tc_name -> let { dc_name  = setRdrNameSpace tc_name dataName ;
  91                                               con_info = PrefixCon [unbangedType $2] }
  92                                         in DataCons [ConDecl dc_name [] [] con_info noSrcLoc]) }
  93
  94 tbind   :: { HsTyVarBndr RdrName }
  95         :  name                    { IfaceTyVar $1 liftedTypeKind }
  96         |  '(' name '::' akind ')' { IfaceTyVar $2 $4 }
  97
  98 tbinds  :: { [HsTyVarBndr RdrName] }
  99         : {- empty -}   { [] }
 100         | tbind tbinds  { $1:$2 }
 101
 102 vdefgs  :: { [[RdrNameHsDecl]] }
 103         : {- empty -}           { [] }
 104         | vdefg ';' vdefgs      { ($1:$3) }
 105
 106 vdefg   :: { [RdrNameHsDecl] }
 107         : '%rec' '{' vdefs1 '}' { map CoreD $3   }
 108         |  vdef                 { [CoreD $1] }
 109
 110 let_bind :: { UfBinding RdrName }
 111         : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3)   }
 112         |  vdef                 { let (b,r) = convBind $1
 113                                   in UfNonRec b r }
 114
 115 vdefs1  :: { [RdrNameCoreDecl] }
 116         : vdef                  { [$1] }
 117         | vdef ';' vdefs1       { $1:$3 }
 118
 119 vdef    :: { RdrNameCoreDecl }
 120         : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc }
 121   -- NB: qname includes data constructors, because
 122   --     we allow data-constructor wrappers at top level
 123
 124
 125 vbind   :: { (RdrName, RdrNameHsType) }
 126         : '(' name '::' ty ')'  { ($2,$4) }
 127
 128 vbinds  :: { [(RdrName, RdrNameHsType)] }
 129         : {-empty -}    { [] }
 130         | vbind vbinds  { $1:$2 }
 131
 132 bind    :: { UfBinder RdrName }
 133         : '@' tbind     { let (IfaceTyVar v k) = $2  in UfTyBinder  v k  }
 134         | vbind         { let (v,ty) = $1 in UfValBinder v ty }
 135
 136 binds1  :: { [UfBinder RdrName] }
 137         : bind          { [$1] }
 138         | bind binds1   { $1:$2 }
 139
 140 attbinds :: { [RdrNameHsTyVar] }
 141         : {- empty -}        { [] }
 142         | '@' tbind attbinds { $2:$3 }
 143
 144 akind   :: { Kind }
 145         : '*'              { liftedTypeKind   }
 146         | '#'              { unliftedTypeKind }
 147         | '?'              { openTypeKind     }
 148         | '(' kind ')'     { $2 }
 149
 150 kind    :: { Kind }
 151         : akind            { $1 }
 152         | akind '->' kind  { mkArrowKind $1 $3 }
 153
 154 cons1   :: { [ConDecl RdrName] }
 155         : con           { [$1] }
 156         | con ';' cons1 { $1:$3 }
 157
 158 con     :: { ConDecl RdrName }
 159         : q_d_patt attbinds atys
 160                 { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
 161
 162 atys    :: { [ RdrNameHsType] }
 163         : {- empty -}   { [] }
 164         | aty atys      { $1:$2 }
 165
 166 aty     :: { RdrNameHsType }
 167         : name       { HsTyVar $1 }
 168         | q_tc_name     { HsTyVar $1 }
 169         | '(' ty ')' { $2 }
 170
 171
 172 bty     :: { RdrNameHsType }
 173         : aty        { $1 }
 174         | bty aty    { HsAppTy $1 $2 }
 175
 176 ty      :: { RdrNameHsType }
 177         : bty                      { $1 }
 178         | bty '->' ty              { HsFunTy $1 $3 }
 179         | '%forall' tbinds '.' ty  { HsForAllTy (Just $2) [] $4 }
 180
 181 aexp    :: { UfExpr RdrName }
 182         : qname         { UfVar $1 }
 183         | lit           { UfLit $1 }
 184         | '(' exp ')'   { $2 }
 185
 186 fexp    :: { UfExpr RdrName }
 187         : fexp aexp     { UfApp $1 $2 }
 188         | fexp '@' aty  { UfApp $1 (UfType $3) }
 189         | aexp          { $1 }
 190
 191 exp     :: { UfExpr RdrName }
 192         : fexp                     { $1 }
 193         | '\\' binds1 '->' exp     { foldr UfLam $4 $2 }
 194         | '%let' let_bind '%in' exp   { UfLet $2 $4 }
 195         | '%case' aexp '%of' vbind
 196           '{' alts1 '}'            { UfCase $2 (fst $4) $6 }
 197         | '%coerce' aty exp        { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
 198         | '%note' STRING exp
 199             { case $2 of
 200                --"SCC"        -> UfNote (UfSCC "scc") $3
 201                "InlineCall" -> UfNote UfInlineCall $3
 202                "InlineMe"   -> UfNote UfInlineMe $3
 203             }
 204         | '%external' STRING aty   { UfFCall (ForeignCall.CCall
 205                                                (CCallSpec (StaticTarget
 206                                                             (mkFastString $2))
 207                                                           CCallConv (PlaySafe False))) $3 }
 208 alts1   :: { [UfAlt RdrName] }
 209         : alt           { [$1] }
 210         | alt ';' alts1 { $1:$3 }
 211
 212 alt     :: { UfAlt RdrName }
 213         : q_d_patt attbinds vbinds '->' exp
 214                 { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
 215         | lit '->' exp
 216                 { (UfLitAlt $1, [], $3) }
 217         | '%_' '->' exp
 218                 { (UfDefault, [], $3) }
 219
 220 lit     :: { Literal }
 221         : '(' INTEGER '::' aty ')'      { convIntLit $2 $4 }
 222         | '(' RATIONAL '::' aty ')'     { convRatLit $2 $4 }
 223         | '(' CHAR '::' aty ')'         { MachChar (fromEnum $2) }
 224         | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
 225
 226 name    :: { RdrName }
 227         : NAME  { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
 228
 229 cname   :: { String }
 230         : CNAME { $1 }
 231
 232 mname   :: { String }
 233         : CNAME { $1 }
 234
 235 modid   :: { ModuleName }
 236         : CNAME { mkSysModuleNameFS (mkFastString $1) }
 237
 238 qname   :: { RdrName }           -- Includes data constructors
 239         : name                   { $1 }
 240         | mname '.' NAME         { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
 241         | q_d_occ                { $1 }
 242
 243
 244 -- Type constructor
 245 q_tc_name       :: { RdrName }
 246         : mname '.' cname
 247                 { mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) }
 248
 249 -- Data constructor in a pattern or data type declaration; use the dataName,
 250 -- because that's what we expect in Core case patterns
 251 q_d_patt :: { RdrName }
 252         : mname '.' cname
 253                 { mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) }
 254
 255 -- Data constructor occurrence in an expression;
 256 -- use the varName because that's the worker Id
 257 q_d_occ :: { RdrName }
 258         : mname '.' cname
 259                 { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
 260
 261
 262 {
 263 convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
 264 convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs)
 265
 266 convIntLit :: Integer -> RdrNameHsType -> Literal
 267 convIntLit i (HsTyVar n)
 268   | n == intPrimRdrName  = MachInt  i
 269   | n == wordPrimRdrName = MachWord i
 270   | n == charPrimRdrName = MachChar (fromInteger i)
 271   | n == addrPrimRdrName && i == 0 = MachNullAddr
 272 convIntLit i aty
 273   = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName)
 274
 275 convRatLit :: Rational -> RdrNameHsType -> Literal
 276 convRatLit r (HsTyVar n)
 277   | n == floatPrimRdrName  = MachFloat  r
 278   | n == doublePrimRdrName = MachDouble r
 279 convRatLit i aty
 280   = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName)
 281
 282
 283 wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName, addrPrimRdrName :: RdrName
 284 wordPrimRdrName   = nameRdrName wordPrimTyConName
 285 intPrimRdrName    = nameRdrName intPrimTyConName
 286 charPrimRdrName   = nameRdrName charPrimTyConName
 287 floatPrimRdrName  = nameRdrName floatPrimTyConName
 288 doublePrimRdrName = nameRdrName doublePrimTyConName
 289 addrPrimRdrName   = nameRdrName addrPrimTyConName
 290
 291 happyError :: P a
 292 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
 293 }
 294