ghc/compiler/parser/ParserCore.y

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