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 vdefs1  :: { [RdrNameHsDecl] }
 102         : vdef                  { [$1] }
 103         | vdef ';' vdefs1       { $1:$3 }
 104
 105 vdef    :: { RdrNameHsDecl }
 106         : qname '::' ty '=' exp { TyClD (CoreDecl  $1 $3 $5 noSrcLoc) }
 107
 108
 109 vbind   :: { (RdrName, RdrNameHsType) }
 110         : '(' name '::' ty ')'  { ($2,$4) }
 111
 112 vbinds  :: { [(RdrName, RdrNameHsType)] }
 113         : {-empty -}    { [] }
 114         | vbind vbinds  { $1:$2 }
 115
 116 bind    :: { UfBinder RdrName }
 117         : '@' tbind     { let (IfaceTyVar v k) = $2  in UfTyBinder  v k  }
 118         | vbind         { let (v,ty) = $1 in UfValBinder v ty }
 119
 120 binds1  :: { [UfBinder RdrName] }
 121         : bind          { [$1] }
 122         | bind binds1   { $1:$2 }
 123
 124 attbinds :: { [RdrNameHsTyVar] }
 125         : {- empty -}        { [] }
 126         | '@' tbind attbinds { $2:$3 }
 127
 128 akind   :: { Kind }
 129         : '*'              { liftedTypeKind   }
 130         | '#'              { unliftedTypeKind }
 131         | '?'              { openTypeKind     }
 132         | '(' kind ')'     { $2 }
 133
 134 kind    :: { Kind }
 135         : akind            { $1 }
 136         | akind '->' kind  { mkArrowKind $1 $3 }
 137
 138 cons1   :: { [ConDecl RdrName] }
 139         : con           { [$1] }
 140         | con ';' cons1 { $1:$3 }
 141
 142 con     :: { ConDecl RdrName }
 143         : q_d_name attbinds atys
 144                 { ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
 145
 146 atys    :: { [ RdrNameHsType] }
 147         : {- empty -}   { [] }
 148         | aty atys      { $1:$2 }
 149
 150 aty     :: { RdrNameHsType }
 151         : name       { HsTyVar $1 }
 152         | q_tc_name     { HsTyVar $1 }
 153         | '(' ty ')' { $2 }
 154
 155
 156 bty     :: { RdrNameHsType }
 157         : aty        { $1 }
 158         | bty aty    { HsAppTy $1 $2 }
 159
 160 ty      :: { RdrNameHsType }
 161         : bty                      { $1 }
 162         | bty '->' ty              { HsFunTy $1 $3 }
 163         | '%forall' tbinds '.' ty  { HsForAllTy (Just $2) [] $4 }
 164
 165 aexp    :: { UfExpr RdrName }
 166         : qname         { UfVar $1 }
 167         | q_d_name      { UfVar $1 }
 168         | lit           { UfLit $1 }
 169         | '(' exp ')'   { $2 }
 170
 171 fexp    :: { UfExpr RdrName }
 172         : fexp aexp     { UfApp $1 $2 }
 173         | fexp '@' aty  { UfApp $1 (UfType $3) }
 174         | aexp          { $1 }
 175
 176 exp     :: { UfExpr RdrName }
 177         : fexp                     { $1 }
 178         | '\\' binds1 '->' exp     { foldr UfLam $4 $2 }
 179         | '%let' vdefg '%in' exp   { UfLet (toUfBinder $2) $4 }
 180         | '%case' aexp '%of' vbind
 181           '{' alts1 '}'            { UfCase $2 (fst $4) $6 }
 182         | '%coerce' aty exp        { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
 183         | '%note' STRING exp
 184             { case $2 of
 185                --"SCC"        -> UfNote (UfSCC "scc") $3
 186                "InlineCall" -> UfNote UfInlineCall $3
 187                "InlineMe"   -> UfNote UfInlineMe $3
 188             }
 189 --        | '%external' STRING aty   { External $2 $3 }
 190
 191 alts1   :: { [UfAlt RdrName] }
 192         : alt           { [$1] }
 193         | alt ';' alts1 { $1:$3 }
 194
 195 alt     :: { UfAlt RdrName }
 196         : q_d_name attbinds vbinds '->' exp
 197                 { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
 198         | lit '->' exp
 199                 { (UfLitAlt $1, [], $3) }
 200         | '%_' '->' exp
 201                 { (UfDefault, [], $3) }
 202
 203 lit     :: { Literal }
 204         : '(' INTEGER '::' aty ')'      { MachInt $2 }
 205         | '(' RATIONAL '::' aty ')'     { MachDouble $2 }
 206         | '(' CHAR '::' aty ')'         { MachChar (fromEnum $2) }
 207         | '(' STRING '::' aty ')'       { MachStr (mkFastString $2) }
 208
 209 name    :: { RdrName }
 210         : NAME  { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }
 211
 212 cname   :: { String }
 213         : CNAME { $1 }
 214
 215 mname   :: { String }
 216         : CNAME { $1 }
 217
 218 modid   :: { ModuleName }
 219         : CNAME { mkSysModuleNameFS (mkFastString $1) }
 220
 221 qname   :: { RdrName }
 222         : name  { $1 }
 223         | mname '.' NAME
 224           { mkIfaceOrig varName (mkFastString $1,mkFastString $3) }
 225
 226 -- Type constructor
 227 q_tc_name       :: { RdrName }
 228         : mname '.' cname
 229                 { mkIfaceOrig tcName (mkFastString $1,mkFastString $3) }
 230
 231 -- Data constructor
 232 q_d_name        :: { RdrName }
 233         : mname '.' cname
 234                 { mkIfaceOrig dataName (mkFastString $1,mkFastString $3) }
 235
 236
 237 {
 238 toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName
 239 toUfBinder xs  =
 240  case xs of
 241    [x] -> uncurry UfNonRec (conv x)
 242    _   -> UfRec (map conv xs)
 243  where
 244   conv (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 }
 250