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