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