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 FastString
  19
  20 #include "../HsVersions.h"
  21
  22 }
  23
  24 %name parseCore
  25 %tokentype { Token }
  26
  27 %token
  28  '%module'      { TKmodule }
  29  '%data'        { TKdata }
  30  '%newtype'     { TKnewtype }
  31  '%forall'      { TKforall }
  32  '%rec'         { TKrec }
  33  '%let'         { TKlet }
  34  '%in'          { TKin }
  35  '%case'        { TKcase }
  36  '%of'          { TKof }
  37  '%coerce'      { TKcoerce }
  38  '%note'        { TKnote }
  39  '%external'    { TKexternal }
  40  '%_'           { TKwild }
  41  '('            { TKoparen }
  42  ')'            { TKcparen }
  43  '{'            { TKobrace }
  44  '}'            { TKcbrace }
  45  '#'            { TKhash}
  46  '='            { TKeq }
  47  '::'           { TKcoloncolon }
  48  '*'            { TKstar }
  49  '->'           { TKrarrow }
  50  '\\'           { TKlambda}
  51  '@'            { TKat }
  52  '.'            { TKdot }
  53  '?'            { TKquestion}
  54  ';'            { TKsemicolon }
  55  NAME           { TKname $$ }
  56  CNAME          { TKcname $$ }
  57  INTEGER        { TKinteger $$ }
  58  RATIONAL       { TKrational $$ }
  59  STRING         { TKstring $$ }
  60  CHAR           { TKchar $$ }
  61
  62 %monad { P } { thenP } { returnP }
  63 %lexer { lexer } { TKEOF }
  64
  65 %%
  66
  67 module  :: { RdrNameHsModule }
  68         : '%module' modid tdefs vdefgs
  69                 { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc}
  70
  71 tdefs   :: { [RdrNameHsDecl] }
  72         : {- empty -}   {[]}
  73         | tdef ';' tdefs        {$1:$3}
  74
  75 tdef    :: { RdrNameHsDecl }
  76         : '%data' q_tc_name tbinds '=' '{' cons1 '}'
  77                 { TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) }
  78         | '%newtype' q_tc_name tbinds trep
  79                 { TyClD (TyData NewType []  $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) }
  80
  81 trep    :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
  82         : {- empty -}   { (\ x ts -> Unknown) }
  83         | '=' ty        { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) }
  84
  85 tbind   :: { HsTyVarBndr RdrName }
  86         :  name                    { IfaceTyVar $1 liftedTypeKind }
  87         |  '(' name '::' akind ')' { IfaceTyVar $2 $4 }
  88
  89 tbinds  :: { [HsTyVarBndr RdrName] }
  90         : {- empty -}   { [] }
  91         | tbind tbinds  { $1:$2 }
  92
  93 vdefgs  :: { [[RdrNameHsDecl]] }
  94         : {- empty -}           { [] }
  95         | vdefg ';' vdefgs      { ($1:$3) }
  96
  97 vdefg   :: { [RdrNameHsDecl] }
  98         : '%rec' '{' vdefs1 '}' { $3   }
  99         |  vdef                 { [$1] }
 100
 101 let_bind :: { UfBinding RdrName }
 102         : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3)   }
 103         |  vdef                 { let (b,r) = convBind $1
 104                                   in UfNonRec b r }
 105
 106 vdefs1  :: { [RdrNameHsDecl] }
 107         : vdef                  { [$1] }
 108         | vdef ';' vdefs1       { $1:$3 }
 109
 110 vdef    :: { RdrNameHsDecl }
 111         : qname '::' ty '=' exp { TyClD (CoreDecl  $1 $3 $5 noSrcLoc) }
 112
 113
 114 vbind   :: { (RdrName, RdrNameHsType) }
 115         : '(' name '::' ty ')'  { ($2,$4) }
 116
 117 vbinds  :: { [(RdrName, RdrNameHsType)] }
 118         : {-empty -}    { [] }
 119         | vbind vbinds  { $1:$2 }
 120
 121 bind    :: { UfBinder RdrName }
 122         : '@' tbind     { let (IfaceTyVar v k) = $2  in UfTyBinder  v k  }
 123         | vbind         { let (v,ty) = $1 in UfValBinder v ty }
 124
 125 binds1  :: { [UfBinder RdrName] }
 126         : bind          { [$1] }
 127         | bind binds1   { $1:$2 }
 128
 129 attbinds :: { [RdrNameHsTyVar] }
 130         : {- empty -}        { [] }
 131         | '@' tbind attbinds { $2:$3 }
 132
 133 akind   :: { Kind }
 134         : '*'              { liftedTypeKind   }
 135         | '#'              { unliftedTypeKind }
 136         | '?'              { openTypeKind     }
 137         | '(' kind ')'     { $2 }
 138
 139 kind    :: { Kind }
 140         : akind            { $1 }
 141         | akind '->' kind  { mkArrowKind $1 $3 }
 142
 143 cons1   :: { [ConDecl RdrName] }
 144         : con           { [$1] }
 145         | con ';' cons1 { $1:$3 }
 146
 147 con     :: { ConDecl RdrName }
 148         : q_d_name attbinds atys
 149                 { ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
 150
 151 atys    :: { [ RdrNameHsType] }
 152         : {- empty -}   { [] }
 153         | aty atys      { $1:$2 }
 154
 155 aty     :: { RdrNameHsType }
 156         : name       { HsTyVar $1 }
 157         | q_tc_name     { HsTyVar $1 }
 158         | '(' ty ')' { $2 }
 159
 160
 161 bty     :: { RdrNameHsType }
 162         : aty        { $1 }
 163         | bty aty    { HsAppTy $1 $2 }
 164
 165 ty      :: { RdrNameHsType }
 166         : bty                      { $1 }
 167         | bty '->' ty              { HsFunTy $1 $3 }
 168         | '%forall' tbinds '.' ty  { HsForAllTy (Just $2) [] $4 }
 169
 170 aexp    :: { UfExpr RdrName }
 171         : qname         { UfVar $1 }
 172         | q_d_name      { UfVar $1 }
 173         | lit           { UfLit $1 }
 174         | '(' exp ')'   { $2 }
 175
 176 fexp    :: { UfExpr RdrName }
 177         : fexp aexp     { UfApp $1 $2 }
 178         | fexp '@' aty  { UfApp $1 (UfType $3) }
 179         | aexp          { $1 }
 180
 181 exp     :: { UfExpr RdrName }
 182         : fexp                     { $1 }
 183         | '\\' binds1 '->' exp     { foldr UfLam $4 $2 }
 184         | '%let' let_bind '%in' exp   { UfLet $2 $4 }
 185         | '%case' aexp '%of' vbind
 186           '{' alts1 '}'            { UfCase $2 (fst $4) $6 }
 187         | '%coerce' aty exp        { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
 188         | '%note' STRING exp
 189             { case $2 of
 190                --"SCC"        -> UfNote (UfSCC "scc") $3
 191                "InlineCall" -> UfNote UfInlineCall $3
 192                "InlineMe"   -> UfNote UfInlineMe $3
 193             }
 194 --        | '%external' STRING aty   { External $2 $3 }
 195
 196 alts1   :: { [UfAlt RdrName] }
 197         : alt           { [$1] }
 198         | alt ';' alts1 { $1:$3 }
 199
 200 alt     :: { UfAlt RdrName }
 201         : q_d_name attbinds vbinds '->' exp
 202                 { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
 203         | lit '->' exp
 204                 { (UfLitAlt $1, [], $3) }
 205         | '%_' '->' exp
 206                 { (UfDefault, [], $3) }
 207
 208 lit     :: { Literal }
 209         : '(' INTEGER '::' aty ')'      { MachInt $2 }
 210         | '(' RATIONAL '::' aty ')'     { MachDouble $2 }
 211         | '(' CHAR '::' aty ')'         { MachChar (fromEnum $2) }
 212         | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
 213
 214 name    :: { RdrName }
 215         : NAME  { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
 216
 217 cname   :: { String }
 218         : CNAME { $1 }
 219
 220 mname   :: { String }
 221         : CNAME { $1 }
 222
 223 modid   :: { ModuleName }
 224         : CNAME { mkSysModuleNameFS (mkFastString $1) }
 225
 226 qname   :: { RdrName }
 227         : name  { $1 }
 228         | mname '.' NAME
 229           { mkIfaceOrig varName (mkFastString $1,mkFastString $3) }
 230
 231 -- Type constructor
 232 q_tc_name       :: { RdrName }
 233         : mname '.' cname
 234                 { mkIfaceOrig tcName (mkFastString $1,mkFastString $3) }
 235
 236 -- Data constructor
 237 q_d_name        :: { RdrName }
 238         : mname '.' cname
 239                 { mkIfaceOrig dataName (mkFastString $1,mkFastString $3) }
 240
 241
 242 {
 243 convBind :: RdrNameHsDecl -> (UfBinder RdrName, UfExpr RdrName)
 244 convBind (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
 245
 246 happyError :: P a
 247 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
 248 }
 249