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 (mkHomeModule $2) Nothing Nothing
  70                            [] ($3 ++ concat $4) Nothing noSrcLoc}
  71
  72 tdefs   :: { [RdrNameHsDecl] }
  73         : {- empty -}   {[]}
  74         | tdef ';' tdefs        {$1:$3}
  75
  76 tdef    :: { RdrNameHsDecl }
  77         : '%data' q_tc_name tbinds '=' '{' cons1 '}'
  78                 { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
  79         | '%newtype' q_tc_name tbinds trep
  80                 { TyClD (mkTyData NewType ([], $2, $3) ($4 $2 $3) Nothing noSrcLoc) }
  81
  82 trep    :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
  83         : {- empty -}   { (\ x ts -> Unknown) }
  84         | '=' ty        { (\ x ts -> DataCons [ConDecl x ts [] (PrefixCon [unbangedType $2]) noSrcLoc]) }
  85
  86 tbind   :: { HsTyVarBndr RdrName }
  87         :  name                    { IfaceTyVar $1 liftedTypeKind }
  88         |  '(' name '::' akind ')' { IfaceTyVar $2 $4 }
  89
  90 tbinds  :: { [HsTyVarBndr RdrName] }
  91         : {- empty -}   { [] }
  92         | tbind tbinds  { $1:$2 }
  93
  94 vdefgs  :: { [[RdrNameHsDecl]] }
  95         : {- empty -}           { [] }
  96         | vdefg ';' vdefgs      { ($1:$3) }
  97
  98 vdefg   :: { [RdrNameHsDecl] }
  99         : '%rec' '{' vdefs1 '}' { map CoreD $3   }
 100         |  vdef                 { [CoreD $1] }
 101
 102 let_bind :: { UfBinding RdrName }
 103         : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3)   }
 104         |  vdef                 { let (b,r) = convBind $1
 105                                   in UfNonRec b r }
 106
 107 vdefs1  :: { [RdrNameCoreDecl] }
 108         : vdef                  { [$1] }
 109         | vdef ';' vdefs1       { $1:$3 }
 110
 111 vdef    :: { RdrNameCoreDecl }
 112         : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc }
 113
 114
 115 vbind   :: { (RdrName, RdrNameHsType) }
 116         : '(' name '::' ty ')'  { ($2,$4) }
 117
 118 vbinds  :: { [(RdrName, RdrNameHsType)] }
 119         : {-empty -}    { [] }
 120         | vbind vbinds  { $1:$2 }
 121
 122 bind    :: { UfBinder RdrName }
 123         : '@' tbind     { let (IfaceTyVar v k) = $2  in UfTyBinder  v k  }
 124         | vbind         { let (v,ty) = $1 in UfValBinder v ty }
 125
 126 binds1  :: { [UfBinder RdrName] }
 127         : bind          { [$1] }
 128         | bind binds1   { $1:$2 }
 129
 130 attbinds :: { [RdrNameHsTyVar] }
 131         : {- empty -}        { [] }
 132         | '@' tbind attbinds { $2:$3 }
 133
 134 akind   :: { Kind }
 135         : '*'              { liftedTypeKind   }
 136         | '#'              { unliftedTypeKind }
 137         | '?'              { openTypeKind     }
 138         | '(' kind ')'     { $2 }
 139
 140 kind    :: { Kind }
 141         : akind            { $1 }
 142         | akind '->' kind  { mkArrowKind $1 $3 }
 143
 144 cons1   :: { [ConDecl RdrName] }
 145         : con           { [$1] }
 146         | con ';' cons1 { $1:$3 }
 147
 148 con     :: { ConDecl RdrName }
 149         : q_d_name attbinds atys
 150                 { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
 151
 152 atys    :: { [ RdrNameHsType] }
 153         : {- empty -}   { [] }
 154         | aty atys      { $1:$2 }
 155
 156 aty     :: { RdrNameHsType }
 157         : name       { HsTyVar $1 }
 158         | q_tc_name     { HsTyVar $1 }
 159         | '(' ty ')' { $2 }
 160
 161
 162 bty     :: { RdrNameHsType }
 163         : aty        { $1 }
 164         | bty aty    { HsAppTy $1 $2 }
 165
 166 ty      :: { RdrNameHsType }
 167         : bty                      { $1 }
 168         | bty '->' ty              { HsFunTy $1 $3 }
 169         | '%forall' tbinds '.' ty  { HsForAllTy (Just $2) [] $4 }
 170
 171 aexp    :: { UfExpr RdrName }
 172         : qname         { UfVar $1 }
 173         | q_d_name      { UfVar $1 }
 174         | lit           { UfLit $1 }
 175         | '(' exp ')'   { $2 }
 176
 177 fexp    :: { UfExpr RdrName }
 178         : fexp aexp     { UfApp $1 $2 }
 179         | fexp '@' aty  { UfApp $1 (UfType $3) }
 180         | aexp          { $1 }
 181
 182 exp     :: { UfExpr RdrName }
 183         : fexp                     { $1 }
 184         | '\\' binds1 '->' exp     { foldr UfLam $4 $2 }
 185         | '%let' let_bind '%in' exp   { UfLet $2 $4 }
 186         | '%case' aexp '%of' vbind
 187           '{' alts1 '}'            { UfCase $2 (fst $4) $6 }
 188         | '%coerce' aty exp        { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
 189         | '%note' STRING exp
 190             { case $2 of
 191                --"SCC"        -> UfNote (UfSCC "scc") $3
 192                "InlineCall" -> UfNote UfInlineCall $3
 193                "InlineMe"   -> UfNote UfInlineMe $3
 194             }
 195 --        | '%external' STRING aty   { External $2 $3 }
 196
 197 alts1   :: { [UfAlt RdrName] }
 198         : alt           { [$1] }
 199         | alt ';' alts1 { $1:$3 }
 200
 201 alt     :: { UfAlt RdrName }
 202         : q_d_name attbinds vbinds '->' exp
 203                 { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
 204         | lit '->' exp
 205                 { (UfLitAlt $1, [], $3) }
 206         | '%_' '->' exp
 207                 { (UfDefault, [], $3) }
 208
 209 lit     :: { Literal }
 210         : '(' INTEGER '::' aty ')'      { MachInt $2 }
 211         | '(' RATIONAL '::' aty ')'     { MachDouble $2 }
 212         | '(' CHAR '::' aty ')'         { MachChar (fromEnum $2) }
 213         | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
 214
 215 name    :: { RdrName }
 216         : NAME  { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
 217
 218 cname   :: { String }
 219         : CNAME { $1 }
 220
 221 mname   :: { String }
 222         : CNAME { $1 }
 223
 224 modid   :: { ModuleName }
 225         : CNAME { mkSysModuleNameFS (mkFastString $1) }
 226
 227 qname   :: { RdrName }
 228         : name  { $1 }
 229         | mname '.' NAME
 230           { mkIfaceOrig varName (mkFastString $1,mkFastString $3) }
 231
 232 -- Type constructor
 233 q_tc_name       :: { RdrName }
 234         : mname '.' cname
 235                 { mkIfaceOrig tcName (mkFastString $1,mkFastString $3) }
 236
 237 -- Data constructor
 238 q_d_name        :: { RdrName }
 239         : mname '.' cname
 240                 { mkIfaceOrig dataName (mkFastString $1,mkFastString $3) }
 241
 242
 243 {
 244 convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
 245 convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs)
 246
 247 happyError :: P a
 248 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
 249 }
 250