utils/ext-core/Parser.y

   1 {
   2 module Parser ( parse ) where
   3
   4 import Core
   5 import ParseGlue
   6 import Lex
   7
   8 }
   9
  10 %name parse
  11 %expect 0
  12 %tokentype { Token }
  13
  14 %token
  15  '%module'      { TKmodule }
  16  '%data'        { TKdata }
  17  '%newtype'     { TKnewtype }
  18  '%forall'      { TKforall }
  19  '%rec'         { TKrec }
  20  '%let'         { TKlet }
  21  '%in'          { TKin }
  22  '%case'        { TKcase }
  23  '%of'          { TKof }
  24  '%cast'        { TKcast }
  25  '%note'        { TKnote }
  26  '%external'    { TKexternal }
  27  '%_'           { TKwild }
  28  '('            { TKoparen }
  29  ')'            { TKcparen }
  30  '{'            { TKobrace }
  31  '}'            { TKcbrace }
  32  '#'            { TKhash}
  33  '='            { TKeq }
  34  '::'           { TKcoloncolon }
  35  '*'            { TKstar }
  36  '->'           { TKrarrow }
  37  '\\'           { TKlambda}
  38  '@'            { TKat }
  39  '.'            { TKdot }
  40  ':'            { TKcolon }
  41  '?'            { TKquestion}
  42  ';'            { TKsemicolon }
  43  NAME           { TKname $$ }
  44  CNAME          { TKcname $$ }
  45  INTEGER        { TKinteger $$ }
  46  RATIONAL       { TKrational $$ }
  47  STRING         { TKstring $$ }
  48  CHAR           { TKchar $$ }
  49
  50 %monad { P } { thenP } { returnP }
  51 %lexer { lexer } { TKEOF }
  52
  53 %%
  54
  55 module  :: { Module }
  56         : '%module' mname tdefs  vdefgs
  57                 { Module $2 $3 $4 }
  58
  59 tdefs   :: { [Tdef] }
  60         : {- empty -}   {[]}
  61         | tdef ';' tdefs        {$1:$3}
  62
  63 tdef    :: { Tdef }
  64         : '%data' qcname tbinds '=' '{' cons1 '}'
  65                 { Data $2 $3 $6 }
  66         | '%newtype' qcname tbinds trep
  67                 { Newtype $2 $3 $4 }
  68
  69 trep    :: { Maybe Ty }
  70         : {- empty -}   {Nothing}
  71         | '=' ty        { Just $2 }
  72
  73 tbind   :: { Tbind }
  74         :  name { ($1,Klifted) }
  75         |  '(' name '::' akind ')'
  76                 { ($2,$4) }
  77
  78 tbinds  :: { [Tbind] }
  79         : {- empty -}   { [] }
  80         | tbind tbinds  { $1:$2 }
  81
  82
  83 vbind   :: { Vbind }
  84         : '(' name '::' ty')'   { ($2,$4) }
  85
  86 vbinds  :: { [Vbind] }
  87         : {-empty -}    { [] }
  88         | vbind vbinds  { $1:$2 }
  89
  90 bind    :: { Bind }
  91         : '@' tbind     { Tb $2 }
  92         | vbind         { Vb $1 }
  93
  94 binds1  :: { [Bind] }
  95         : bind          { [$1] }
  96         | bind binds1   { $1:$2 }
  97
  98 attbinds :: { [Tbind] }
  99         : {- empty -}   { [] }
 100         | '@' tbind attbinds
 101                         { $2:$3 }
 102
 103 akind   :: { Kind }
 104         : '*'           {Klifted}
 105         | '#'           {Kunlifted}
 106         | '?'           {Kopen}
 107         | '(' kind ')'  { $2 }
 108
 109 kind    :: { Kind }
 110         : akind         { $1 }
 111         | akind '->' kind
 112                 { Karrow $1 $3 }
 113
 114 cons1   :: { [Cdef] }
 115         : con           { [$1] }
 116         | con ';' cons1 { $1:$3 }
 117
 118 con     :: { Cdef }
 119         : qcname attbinds atys
 120                 { Constr $1 $2 $3 }
 121
 122 atys    :: { [Ty] }
 123         : {- empty -} { [] }
 124         | aty atys      { $1:$2 }
 125
 126 aty     :: { Ty }
 127         : name  { Tvar $1 }
 128         | qcname { Tcon $1 }
 129         | '(' ty ')' { $2 }
 130
 131
 132 bty     :: { Ty }
 133         : aty   { $1 }
 134         | bty aty { Tapp $1 $2 }
 135
 136 ty      :: { Ty }
 137         : bty   {$1}
 138         | bty '->' ty
 139                 { tArrow $1 $3 }
 140         | '%forall' tbinds '.' ty
 141                 { foldr Tforall $4 $2 }
 142
 143 vdefgs  :: { [Vdefg] }
 144         : {- empty -}           { [] }
 145         | vdefg ';' vdefgs      {$1:$3 }
 146
 147 vdefg   :: { Vdefg }
 148         : '%rec' '{' vdefs1 '}'
 149                        { Rec $3 }
 150         |  vdef { Nonrec $1}
 151
 152 vdefs1  :: { [Vdef] }
 153         : vdef          { [$1] }
 154         | vdef ';' vdefs1 { $1:$3 }
 155
 156 vdef    :: { Vdef }
 157         : qname '::' ty '=' exp
 158                 { Vdef ($1,$3,$5) }
 159
 160 aexp    :: { Exp }
 161         : qname         { Var $1 }
 162         | qcname        { Dcon $1 }
 163         | lit           { Lit $1 }
 164         | '(' exp ')'   { $2 }
 165
 166 fexp    :: { Exp }
 167         : fexp aexp     { App $1 $2 }
 168         | fexp '@' aty  { Appt $1 $3 }
 169         | aexp          { $1 }
 170
 171 exp     :: { Exp }
 172         : fexp          { $1 }
 173         | '\\' binds1 '->' exp
 174                 { foldr Lam $4 $2 }
 175         | '%let' vdefg '%in' exp
 176                 { Let $2 $4 }
 177         | '%case' '(' ty ')' aexp '%of' vbind '{' alts1 '}'
 178                 { Case $5 $7 $3 $9 }
 179 -- Note: ty, not aty! You can cast something to a forall type
 180 -- Though now we have shift/reduce conflicts like woah
 181         | '%cast' exp ty
 182                 { Cast $2 $3 }
 183         | '%note' STRING exp
 184                 { Note $2 $3 }
 185         | '%external' STRING aty
 186                 { External $2 $3 }
 187
 188 alts1   :: { [Alt] }
 189         : alt           { [$1] }
 190         | alt ';' alts1 { $1:$3 }
 191
 192 alt     :: { Alt }
 193         : qcname attbinds vbinds '->' exp
 194                 { Acon $1 $2 $3 $5 }
 195         | lit '->' exp
 196                 { Alit $1 $3 }
 197         | '%_' '->' exp
 198                 { Adefault $3 }
 199
 200 lit     :: { Lit }
 201         : '(' INTEGER '::' aty ')'
 202                 { Lint $2 $4 }
 203         | '(' RATIONAL '::' aty ')'
 204                 { Lrational $2 $4 }
 205         | '(' CHAR '::' aty ')'
 206                 { Lchar $2 $4 }
 207         | '(' STRING '::' aty ')'
 208                 { Lstring $2 $4 }
 209
 210 name    :: { Id }
 211         : NAME  { $1 }
 212
 213 cname   :: { Id }
 214         : CNAME { $1 }
 215
 216 mname   :: { AnMname }
 217         : pkgName ':' cname
 218              { let (parentNames, childName) = splitModuleName $3 in
 219                  ($1, parentNames, childName) }
 220
 221 pkgName :: { Id }
 222         : NAME { $1 }
 223
 224 -- TODO: Clean this up. Now hierarchical names are z-encoded.
 225
 226 -- note that a sequence of mnames is either:
 227 -- empty, or a series of cnames separated by
 228 -- dots, with a leading dot
 229 -- See the definition of mnames: the "name" part
 230 -- is required.
 231 mnames :: { [Id] }
 232          : {- empty -} {[]}
 233          | '.' cname mnames {$2:$3}
 234
 235 -- it sucks to have to repeat the Maybe-checking twice,
 236 -- but otherwise we get reduce/reduce conflicts
 237
 238 -- TODO: this is the ambiguity here. mname '.' name --
 239 -- but by maximal-munch, in GHC.Base.Bool the entire
 240 -- thing gets counted as the module name. What to do,
 241 -- besides z-encoding the dots in the hierarchy again?
 242 -- (Or using syntax other than a dot to separate the
 243 -- module name from the variable name...)
 244 qname   :: { (Mname,Id) }
 245         : name { (Nothing, $1) }
 246         | mname '.' name
 247                 { (Just $1,$3) }
 248
 249 qcname  :: { (Mname,Id) }
 250         : cname { (Nothing, $1) }
 251         | mname '.' cname
 252                 { (Just $1,$3) }
 253
 254
 255 {
 256
 257 happyError :: P a
 258 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
 259
 260 }