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