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 (mkHomeModule $2) Nothing 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 $3) Nothing noSrcLoc) }
  83
  84 trep    :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
  85         : {- empty -}   { (\ x ts -> Unknown) }
  86         | '=' ty        { (\ x ts -> DataCons [ConDecl x ts [] (PrefixCon [unbangedType $2]) noSrcLoc]) }
  87
  88 tbind   :: { HsTyVarBndr RdrName }
  89         :  name                    { IfaceTyVar $1 liftedTypeKind }
  90         |  '(' name '::' akind ')' { IfaceTyVar $2 $4 }
  91
  92 tbinds  :: { [HsTyVarBndr RdrName] }
  93         : {- empty -}   { [] }
  94         | tbind tbinds  { $1:$2 }
  95
  96 vdefgs  :: { [[RdrNameHsDecl]] }
  97         : {- empty -}           { [] }
  98         | vdefg ';' vdefgs      { ($1:$3) }
  99
 100 vdefg   :: { [RdrNameHsDecl] }
 101         : '%rec' '{' vdefs1 '}' { map CoreD $3   }
 102         |  vdef                 { [CoreD $1] }
 103
 104 let_bind :: { UfBinding RdrName }
 105         : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3)   }
 106         |  vdef                 { let (b,r) = convBind $1
 107                                   in UfNonRec b r }
 108
 109 vdefs1  :: { [RdrNameCoreDecl] }
 110         : vdef                  { [$1] }
 111         | vdef ';' vdefs1       { $1:$3 }
 112
 113 vdef    :: { RdrNameCoreDecl }
 114         : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc }
 115   -- NB: qname includes data constructors, because
 116   --     we allow data-constructor wrappers at top level
 117
 118
 119 vbind   :: { (RdrName, RdrNameHsType) }
 120         : '(' name '::' ty ')'  { ($2,$4) }
 121
 122 vbinds  :: { [(RdrName, RdrNameHsType)] }
 123         : {-empty -}    { [] }
 124         | vbind vbinds  { $1:$2 }
 125
 126 bind    :: { UfBinder RdrName }
 127         : '@' tbind     { let (IfaceTyVar v k) = $2  in UfTyBinder  v k  }
 128         | vbind         { let (v,ty) = $1 in UfValBinder v ty }
 129
 130 binds1  :: { [UfBinder RdrName] }
 131         : bind          { [$1] }
 132         | bind binds1   { $1:$2 }
 133
 134 attbinds :: { [RdrNameHsTyVar] }
 135         : {- empty -}        { [] }
 136         | '@' tbind attbinds { $2:$3 }
 137
 138 akind   :: { Kind }
 139         : '*'              { liftedTypeKind   }
 140         | '#'              { unliftedTypeKind }
 141         | '?'              { openTypeKind     }
 142         | '(' kind ')'     { $2 }
 143
 144 kind    :: { Kind }
 145         : akind            { $1 }
 146         | akind '->' kind  { mkArrowKind $1 $3 }
 147
 148 cons1   :: { [ConDecl RdrName] }
 149         : con           { [$1] }
 150         | con ';' cons1 { $1:$3 }
 151
 152 con     :: { ConDecl RdrName }
 153         : q_d_patt attbinds atys
 154                 { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
 155
 156 atys    :: { [ RdrNameHsType] }
 157         : {- empty -}   { [] }
 158         | aty atys      { $1:$2 }
 159
 160 aty     :: { RdrNameHsType }
 161         : name       { HsTyVar $1 }
 162         | q_tc_name     { HsTyVar $1 }
 163         | '(' ty ')' { $2 }
 164
 165
 166 bty     :: { RdrNameHsType }
 167         : aty        { $1 }
 168         | bty aty    { HsAppTy $1 $2 }
 169
 170 ty      :: { RdrNameHsType }
 171         : bty                      { $1 }
 172         | bty '->' ty              { HsFunTy $1 $3 }
 173         | '%forall' tbinds '.' ty  { HsForAllTy (Just $2) [] $4 }
 174
 175 aexp    :: { UfExpr RdrName }
 176         : qname         { UfVar $1 }
 177         | lit           { UfLit $1 }
 178         | '(' exp ')'   { $2 }
 179
 180 fexp    :: { UfExpr RdrName }
 181         : fexp aexp     { UfApp $1 $2 }
 182         | fexp '@' aty  { UfApp $1 (UfType $3) }
 183         | aexp          { $1 }
 184
 185 exp     :: { UfExpr RdrName }
 186         : fexp                     { $1 }
 187         | '\\' binds1 '->' exp     { foldr UfLam $4 $2 }
 188         | '%let' let_bind '%in' exp   { UfLet $2 $4 }
 189         | '%case' aexp '%of' vbind
 190           '{' alts1 '}'            { UfCase $2 (fst $4) $6 }
 191         | '%coerce' aty exp        { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
 192         | '%note' STRING exp
 193             { case $2 of
 194                --"SCC"        -> UfNote (UfSCC "scc") $3
 195                "InlineCall" -> UfNote UfInlineCall $3
 196                "InlineMe"   -> UfNote UfInlineMe $3
 197             }
 198 --        | '%external' STRING aty   { External $2 $3 }
 199
 200 alts1   :: { [UfAlt RdrName] }
 201         : alt           { [$1] }
 202         | alt ';' alts1 { $1:$3 }
 203
 204 alt     :: { UfAlt RdrName }
 205         : q_d_patt attbinds vbinds '->' exp
 206                 { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
 207         | lit '->' exp
 208                 { (UfLitAlt $1, [], $3) }
 209         | '%_' '->' exp
 210                 { (UfDefault, [], $3) }
 211
 212 lit     :: { Literal }
 213         : '(' INTEGER '::' aty ')'      { convIntLit $2 $4 }
 214         | '(' RATIONAL '::' aty ')'     { convRatLit $2 $4 }
 215         | '(' CHAR '::' aty ')'         { MachChar (fromEnum $2) }
 216         | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
 217
 218 name    :: { RdrName }
 219         : NAME  { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
 220
 221 cname   :: { String }
 222         : CNAME { $1 }
 223
 224 mname   :: { String }
 225         : CNAME { $1 }
 226
 227 modid   :: { ModuleName }
 228         : CNAME { mkSysModuleNameFS (mkFastString $1) }
 229
 230 qname   :: { RdrName }           -- Includes data constructors
 231         : name                   { $1 }
 232         | mname '.' NAME         { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
 233         | q_d_occ                { $1 }
 234
 235
 236 -- Type constructor
 237 q_tc_name       :: { RdrName }
 238         : mname '.' cname
 239                 { mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) }
 240
 241 -- Data constructor in a pattern or data type declaration; use the dataName,
 242 -- because that's what we expect in Core case patterns
 243 q_d_patt :: { RdrName }
 244         : mname '.' cname
 245                 { mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) }
 246
 247 -- Data constructor occurrence in an expression;
 248 -- use the varName because that's the worker Id
 249 q_d_occ :: { RdrName }
 250         : mname '.' cname
 251                 { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
 252
 253
 254 {
 255 convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
 256 convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs)
 257
 258 convIntLit :: Integer -> RdrNameHsType -> Literal
 259 convIntLit i (HsTyVar n)
 260   | n == intPrimRdrName  = MachInt  i
 261   | n == wordPrimRdrName = MachWord i
 262 convIntLit i aty
 263   = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName)
 264
 265 convRatLit :: Rational -> RdrNameHsType -> Literal
 266 convRatLit r (HsTyVar n)
 267   | n == floatPrimRdrName  = MachFloat  r
 268   | n == doublePrimRdrName = MachDouble r
 269 convRatLit i aty
 270   = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName)
 271
 272
 273 wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName :: RdrName
 274 wordPrimRdrName   = nameRdrName wordPrimTyConName
 275 intPrimRdrName    = nameRdrName intPrimTyConName
 276 floatPrimRdrName  = nameRdrName floatPrimTyConName
 277 doublePrimRdrName = nameRdrName doublePrimTyConName
 278
 279 happyError :: P a
 280 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
 281 }
 282