Parser.y 160 KB
Newer Older
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1
--                                                              -*-haskell-*-
2 3 4 5 6 7 8 9 10
-- ---------------------------------------------------------------------------
-- (c) The University of Glasgow 1997-2003
---
-- The GHC grammar.
--
-- Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999
-- ---------------------------------------------------------------------------

{
11
{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
12
{-# OPTIONS -Wwarn -w #-}
13 14 15
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
16
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 18
-- for details

19 20 21 22 23 24 25 26 27 28 29 30
-- | This module provides the generated Happy parser for Haskell. It exports
-- a number of parsers which may be used in any library that uses the GHC API.
-- A common usage pattern is to initialize the parser state with a given string
-- and then parse that string:
--
-- @
--     runParser :: DynFlags -> String -> P a -> ParseResult a
--     runParser flags str parser = unP parser parseState
--     where
--       filename = "\<interactive\>"
--       location = mkRealSrcLoc (mkFastString filename) 1 1
--       buffer = stringToStringBuffer str
31
--       parseState = mkPState flags buffer location
32 33 34 35 36 37
-- @
module Parser (parseModule, parseImport, parseStatement,
               parseDeclaration, parseExpression, parseTypeSignature,
               parseFullStmt, parseStmt, parseIdentifier,
               parseType, parseHeader) where

rodlogic's avatar
rodlogic committed
38 39 40 41 42
-- base
import Control.Monad    ( unless, liftM )
import GHC.Exts
import Data.Char
import Control.Monad    ( mplus )
43

rodlogic's avatar
rodlogic committed
44
-- compiler/hsSyn
45
import HsSyn
rodlogic's avatar
rodlogic committed
46 47

-- compiler/main
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
48
import HscTypes         ( IsBootInterface, WarningTxt(..) )
rodlogic's avatar
rodlogic committed
49 50 51 52 53 54 55 56 57 58
import DynFlags

-- compiler/utils
import OrdList
import BooleanFormula   ( BooleanFormula, mkAnd, mkOr, mkTrue, mkVar )
import FastString
import Maybes           ( orElse )
import Outputable

-- compiler/basicTypes
59
import RdrName
thomasw's avatar
thomasw committed
60
import OccName          ( varName, dataName, tcClsName, tvName, startsWithUnderscore )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
61
import DataCon          ( DataCon, dataConName )
Ian Lynagh's avatar
Ian Lynagh committed
62
import SrcLoc
63
import Module
rodlogic's avatar
rodlogic committed
64 65 66 67
import BasicTypes

-- compiler/types
import Type             ( funTyCon )
dreixel's avatar
dreixel committed
68
import Kind             ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
69
import Class            ( FunDep )
rodlogic's avatar
rodlogic committed
70 71 72 73

-- compiler/parser
import RdrHsSyn
import Lexer
74
import HaddockUtils
Alan Zimmerman's avatar
Alan Zimmerman committed
75
import ApiAnnotation
76

rodlogic's avatar
rodlogic committed
77 78
-- compiler/typecheck
import TcEvidence       ( emptyTcEvBinds )
79

rodlogic's avatar
rodlogic committed
80 81 82 83 84 85
-- compiler/prelude
import ForeignCall
import TysPrim          ( liftedTypeKindTyConName, eqPrimTyCon )
import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
                          unboxedUnitTyCon, unboxedUnitDataCon,
                          listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
Alan Zimmerman's avatar
Alan Zimmerman committed
86

87 88
}

89
{- Last updated: 03 Mar 2015
90 91 92 93

Conflicts: 48 shift/reduce
           1  reduce/reduce

94 95
If you modify this parser and add a conflict, please update this comment.
You can learn more about the conflicts by passing 'happy' the -i flag:
96

97
    happy -agc --strict compiler/parser/Parser.y -idetailed-info
98

99 100 101 102 103 104
How is this section formatted? Look up the state the conflict is
reported at, and copy the list of applicable rules (at the top).  Mark
*** for the rule that is the conflicting reduction (that is, the
interpretation which is NOT taken).  NB: Happy doesn't print a rule in a
state if it is empty, but you should include it in the list (you can
look these up in the Grammar section of the info file).
105

106 107 108 109 110
Obviously the state numbers are not stable across modifications to the parser,
the idea is to reproduce enough information on each conflict so you can figure
out what happened if the states were renumbered.  Try not to gratuitously move
productions around in this file.  It's probably less important to keep
the rule annotations up-to-date.
111

112
-------------------------------------------------------------------------------
Gabor Greif's avatar
Gabor Greif committed
113

114
state 0 contains 1 shift/reduce conflicts.
Gabor Greif's avatar
Gabor Greif committed
115

116
    Conflicts: DOCNEXT (empty missing_module_keyword reduces)
117

118 119 120
Ambiguity when the source file starts with "-- | doc". We need another
token of lookahead to determine if a top declaration or the 'module' keyword
follows. Shift parses as if the 'module' keyword follows.
121

122
-------------------------------------------------------------------------------
123

124
state 49 contains 10 shift/reduce conflicts.
125

126 127 128 129 130 131 132 133 134 135
        context -> btype . '~' btype                        (rule 279)
        context -> btype .                                  (rule 280)
    *** type -> btype .                                     (rule 281)
        type -> btype . qtyconop type                       (rule 282)
        type -> btype . tyvarop type                        (rule 283)
        type -> btype . '->' ctype                          (rule 284)
        type -> btype . '~' btype                           (rule 285)
        type -> btype . SIMPLEQUOTE qconop type             (rule 286)
        type -> btype . SIMPLEQUOTE varop type              (rule 287)
        btype -> btype . atype                              (rule 299)
136

137
    Conflicts: '->' '-' '!' '*' '.' '`' VARSYM CONSYM QVARSYM QCONSYM
138

139 140 141
Example of ambiguity: 'e :: a `b` c';  does this mean
    (e::a) `b` c, or
    (e :: (a `b` c))
142

143 144 145 146 147 148 149 150
The case for '->' involves view patterns rather than type operators:
    'case v of { x :: T -> T ... } '
    Which of these two is intended?
          case v of
            (x::T) -> T         -- Rhs is T
    or
          case v of
            (x::T -> T) -> ..   -- Rhs is ...
151

152
-------------------------------------------------------------------------------
153

154
state 118 contains 15 shift/reduce conflicts.
155

156 157 158 159 160 161 162
        exp -> infixexp . '::' sigtype                      (rule 414)
        exp -> infixexp . '-<' exp                          (rule 415)
        exp -> infixexp . '>-' exp                          (rule 416)
        exp -> infixexp . '-<<' exp                         (rule 417)
        exp -> infixexp . '>>-' exp                         (rule 418)
    *** exp -> infixexp .                                   (rule 419)
        infixexp -> infixexp . qop exp10                    (rule 421)
163

164 165
    Conflicts: ':' '::' '-' '!' '*' '-<' '>-' '-<<' '>>-'
               '.' '`' VARSYM CONSYM QVARSYM QCONSYM
166

167 168 169 170
Examples of ambiguity:
    'if x then y else z -< e'
    'if x then y else z :: T'
    'if x then y else z + 1' (NB: '+' is in VARSYM)
171

172 173 174 175
Shift parses as (per longest-parse rule):
    'if x then y else (z -< T)'
    'if x then y else (z :: T)'
    'if x then y else (z + 1)'
176

177
-------------------------------------------------------------------------------
178

179
state 276 contains 1 shift/reduce conflicts.
180

181
        rule -> STRING . rule_activation rule_forall infixexp '=' exp    (rule 214)
182

183
    Conflict: '[' (empty rule_activation reduces)
184

185 186 187
We don't know whether the '[' starts the activation or not: it
might be the start of the declaration with the activation being
empty.  --SDM 1/4/2002
188

189 190
Example ambiguity:
    '{-# RULE [0] f = ... #-}'
191

192 193
We parse this as having a [0] rule activation for rewriting 'f', rather
a rule instructing how to rewrite the expression '[0] f'.
194

195
-------------------------------------------------------------------------------
ross's avatar
ross committed
196

197
state 285 contains 10 shift/reduce conflicts.
198

199 200 201 202 203 204 205 206
    *** type -> btype .                                     (rule 281)
        type -> btype . qtyconop type                       (rule 282)
        type -> btype . tyvarop type                        (rule 283)
        type -> btype . '->' ctype                          (rule 284)
        type -> btype . '~' btype                           (rule 285)
        type -> btype . SIMPLEQUOTE qconop type             (rule 286)
        type -> btype . SIMPLEQUOTE varop type              (rule 287)
        btype -> btype . atype                              (rule 299)
207

208
    Conflicts: [elided]
209

210
Same as State 49, but minus the context productions.
211

212
-------------------------------------------------------------------------------
213

214
state 320 contains 1 shift/reduce conflicts.
215

216 217 218
        tup_exprs -> commas . tup_tail                      (rule 502)
        sysdcon -> '(' commas . ')'                         (rule 610)
        commas -> commas . ','                              (rule 724)
219

220
    Conflict: ')' (empty tup_tail reduces)
221

222 223 224 225
A tuple section with NO free variables '(,,)' is indistinguishable
from the Haskell98 data constructor for a tuple.  Shift resolves in
favor of sysdcon, which is good because a tuple section will get rejected
if -XTupleSections is not specified.
226

227
-------------------------------------------------------------------------------
228

229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363
state 372 contains 1 shift/reduce conflicts.

        tup_exprs -> commas . tup_tail                      (rule 502)
        sysdcon -> '(#' commas . '#)'                       (rule 612)
        commas -> commas . ','                              (rule 724)

    Conflict: '#)' (empty tup_tail reduces)

Same as State 320 for unboxed tuples.

-------------------------------------------------------------------------------

state 400 contains 1 shift/reduce conflicts.

        exp10 -> 'let' binds . 'in' exp                     (rule 423)
        exp10 -> 'let' binds . 'in' error                   (rule 438)
        exp10 -> 'let' binds . error                        (rule 439)
    *** qual -> 'let' binds .                               (rule 576)

    Conflict: error

TODO: Why?

-------------------------------------------------------------------------------

state 432 contains 1 shift/reduce conflicts.

        atype -> SIMPLEQUOTE '[' . comma_types0 ']'         (rule 318)
        sysdcon -> '[' . ']'                                (rule 613)

    Conflict: ']' (empty comma_types0 reudes)

TODO: Why?

-------------------------------------------------------------------------------

state 461 contains 1 shift/reduce conflicts.

    *** strict_mark -> '{-# NOUNPACK' '#-}' .               (rule 268)
        strict_mark -> '{-# NOUNPACK' '#-}' . '!'           (rule 270)

    Conflict: '!'

TODO: Why?

-------------------------------------------------------------------------------

state 462 contains 1 shift/reduce conflicts.

    *** strict_mark -> '{-# UNPACK' '#-}' .                 (rule 267)
        strict_mark -> '{-# UNPACK' '#-}' . '!'             (rule 269)

    Conflict: '!'

Same as State 462

-------------------------------------------------------------------------------

state 493 contains 1 shift/reduce conflicts.

        context -> btype '~' btype .                        (rule 279)
    *** type -> btype '~' btype .                           (rule 285)
        btype -> btype . atype                              (rule 299)

    Conflict: '!'

TODO: Why?

-------------------------------------------------------------------------------

state 628 contains 1 shift/reduce conflicts.

    *** aexp2 -> ipvar .                                    (rule 462)
        dbind -> ipvar . '=' exp                            (rule 587)

    Conflict: '='

Example ambiguity: 'let ?x ...'

The parser can't tell whether the ?x is the lhs of a normal binding or
an implicit binding.  Fortunately, resolving as shift gives it the only
sensible meaning, namely the lhs of an implicit binding.

-------------------------------------------------------------------------------

state 695 contains 1 shift/reduce conflicts.

        rule -> STRING rule_activation . rule_forall infixexp '=' exp    (rule 214)

    Conflict: 'forall' (empty rule_forall reduces)

Example ambiguity: '{-# RULES "name" forall = ... #-}'

'forall' is a valid variable name---we don't know whether
to treat a forall on the input as the beginning of a quantifier
or the beginning of the rule itself.  Resolving to shift means
it's always treated as a quantifier, hence the above is disallowed.
This saves explicitly defining a grammar for the rule lhs that
doesn't include 'forall'.

-------------------------------------------------------------------------------

state 768 contains 1 shift/reduce conflicts.

    *** type -> btype '~' btype .                           (rule 285)
        btype -> btype . atype                              (rule 299)

    Conflict: '!'

TODO: Why?

-------------------------------------------------------------------------------

state 951 contains 1 shift/reduce conflicts.

        transformqual -> 'then' 'group' . 'using' exp       (rule 525)
        transformqual -> 'then' 'group' . 'by' exp 'using' exp    (rule 526)
    *** special_id -> 'group' .                             (rule 700)

    Conflict: 'by'

TODO: Why?

-------------------------------------------------------------------------------

state 1228 contains 1 reduce/reduce conflicts.

    *** tyconsym -> CONSYM .                                (rule 640)
        consym -> CONSYM .                                  (rule 710)

    Conflict: ')'

TODO: Why?  (NB: This one has been around for a while; it's quite puzzling
    because we really shouldn't get confused between tyconsym and consym.
    Trace the state machine, maybe?)
364

365 366
-- -----------------------------------------------------------------------------
-- API Annotations
367
--
368 369 370 371 372 373 374 375 376 377 378

A lot of the productions are now cluttered with calls to
aa,am,ams,amms etc.

These are helper functions to make sure that the locations of the
various keywords such as do / let / in are captured for use by tools
that want to do source to source conversions, such as refactorers or
structured editors.

The helper functions are defined at the bottom of this file.

379 380 381 382
See
  https://ghc.haskell.org/trac/ghc/wiki/ApiAnnotations and
  https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations
for some background.
383

384 385 386 387 388
-- -----------------------------------------------------------------------------

-}

%token
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
389 390
 '_'            { L _ ITunderscore }            -- Haskell keywords
 'as'           { L _ ITas }
391 392 393
 'case'         { L _ ITcase }
 'class'        { L _ ITclass }
 'data'         { L _ ITdata }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417
 'default'      { L _ ITdefault }
 'deriving'     { L _ ITderiving }
 'do'           { L _ ITdo }
 'else'         { L _ ITelse }
 'hiding'       { L _ IThiding }
 'if'           { L _ ITif }
 'import'       { L _ ITimport }
 'in'           { L _ ITin }
 'infix'        { L _ ITinfix }
 'infixl'       { L _ ITinfixl }
 'infixr'       { L _ ITinfixr }
 'instance'     { L _ ITinstance }
 'let'          { L _ ITlet }
 'module'       { L _ ITmodule }
 'newtype'      { L _ ITnewtype }
 'of'           { L _ ITof }
 'qualified'    { L _ ITqualified }
 'then'         { L _ ITthen }
 'type'         { L _ ITtype }
 'where'        { L _ ITwhere }

 'forall'       { L _ ITforall }                -- GHC extension keywords
 'foreign'      { L _ ITforeign }
 'export'       { L _ ITexport }
418
 'label'        { L _ ITlabel }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
419 420
 'dynamic'      { L _ ITdynamic }
 'safe'         { L _ ITsafe }
421
 'interruptible' { L _ ITinterruptible }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
422 423 424
 'unsafe'       { L _ ITunsafe }
 'mdo'          { L _ ITmdo }
 'family'       { L _ ITfamily }
425
 'role'         { L _ ITrole }
426 427
 'stdcall'      { L _ ITstdcallconv }
 'ccall'        { L _ ITccallconv }
428
 'capi'         { L _ ITcapiconv }
429
 'prim'         { L _ ITprimcallconv }
thoughtpolice's avatar
thoughtpolice committed
430
 'javascript'   { L _ ITjavascriptcallconv }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
431 432
 'proc'         { L _ ITproc }          -- for arrow notation extension
 'rec'          { L _ ITrec }           -- for arrow notation extension
433 434 435
 'group'    { L _ ITgroup }     -- for list transform extension
 'by'       { L _ ITby }        -- for list transform extension
 'using'    { L _ ITusing }     -- for list transform extension
cactus's avatar
cactus committed
436
 'pattern'      { L _ ITpattern } -- for pattern synonyms
Facundo Domínguez's avatar
Facundo Domínguez committed
437
 'static'       { L _ ITstatic }  -- for static pointers extension
438

Alan Zimmerman's avatar
Alan Zimmerman committed
439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461
 '{-# INLINE'             { L _ (ITinline_prag _ _ _) }
 '{-# SPECIALISE'         { L _ (ITspec_prag _) }
 '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }
 '{-# SOURCE'             { L _ (ITsource_prag _) }
 '{-# RULES'              { L _ (ITrules_prag _) }
 '{-# CORE'               { L _ (ITcore_prag _) }      -- hdaume: annotated core
 '{-# SCC'                { L _ (ITscc_prag _)}
 '{-# GENERATED'          { L _ (ITgenerated_prag _) }
 '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }
 '{-# WARNING'            { L _ (ITwarning_prag _) }
 '{-# UNPACK'             { L _ (ITunpack_prag _) }
 '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }
 '{-# ANN'                { L _ (ITann_prag _) }
 '{-# VECTORISE'          { L _ (ITvect_prag _) }
 '{-# VECTORISE_SCALAR'   { L _ (ITvect_scalar_prag _) }
 '{-# NOVECTORISE'        { L _ (ITnovect_prag _) }
 '{-# MINIMAL'            { L _ (ITminimal_prag _) }
 '{-# CTYPE'              { L _ (ITctype _) }
 '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }
 '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }
 '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }
 '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }
 '#-}'                    { L _ ITclose_prag }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
462 463 464 465 466 467

 '..'           { L _ ITdotdot }                        -- reserved symbols
 ':'            { L _ ITcolon }
 '::'           { L _ ITdcolon }
 '='            { L _ ITequal }
 '\\'           { L _ ITlam }
468
 'lcase'        { L _ ITlcase }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501
 '|'            { L _ ITvbar }
 '<-'           { L _ ITlarrow }
 '->'           { L _ ITrarrow }
 '@'            { L _ ITat }
 '~'            { L _ ITtilde }
 '~#'           { L _ ITtildehsh }
 '=>'           { L _ ITdarrow }
 '-'            { L _ ITminus }
 '!'            { L _ ITbang }
 '*'            { L _ ITstar }
 '-<'           { L _ ITlarrowtail }            -- for arrow notation
 '>-'           { L _ ITrarrowtail }            -- for arrow notation
 '-<<'          { L _ ITLarrowtail }            -- for arrow notation
 '>>-'          { L _ ITRarrowtail }            -- for arrow notation
 '.'            { L _ ITdot }

 '{'            { L _ ITocurly }                        -- special symbols
 '}'            { L _ ITccurly }
 vocurly        { L _ ITvocurly } -- virtual open curly (from layout)
 vccurly        { L _ ITvccurly } -- virtual close curly (from layout)
 '['            { L _ ITobrack }
 ']'            { L _ ITcbrack }
 '[:'           { L _ ITopabrack }
 ':]'           { L _ ITcpabrack }
 '('            { L _ IToparen }
 ')'            { L _ ITcparen }
 '(#'           { L _ IToubxparen }
 '#)'           { L _ ITcubxparen }
 '(|'           { L _ IToparenbar }
 '|)'           { L _ ITcparenbar }
 ';'            { L _ ITsemi }
 ','            { L _ ITcomma }
 '`'            { L _ ITbackquote }
dreixel's avatar
dreixel committed
502
 SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
503 504 505 506 507 508 509 510 511

 VARID          { L _ (ITvarid    _) }          -- identifiers
 CONID          { L _ (ITconid    _) }
 VARSYM         { L _ (ITvarsym   _) }
 CONSYM         { L _ (ITconsym   _) }
 QVARID         { L _ (ITqvarid   _) }
 QCONID         { L _ (ITqconid   _) }
 QVARSYM        { L _ (ITqvarsym  _) }
 QCONSYM        { L _ (ITqconsym  _) }
512 513
 PREFIXQVARSYM  { L _ (ITprefixqvarsym  _) }
 PREFIXQCONSYM  { L _ (ITprefixqconsym  _) }
514

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
515 516
 IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension

517 518 519
 CHAR           { L _ (ITchar   _ _) }
 STRING         { L _ (ITstring _ _) }
 INTEGER        { L _ (ITinteger _ _) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
520
 RATIONAL       { L _ (ITrational _) }
521

522 523 524 525
 PRIMCHAR       { L _ (ITprimchar   _ _) }
 PRIMSTRING     { L _ (ITprimstring _ _) }
 PRIMINTEGER    { L _ (ITprimint    _ _) }
 PRIMWORD       { L _ (ITprimword   _ _) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
526 527 528 529 530 531 532
 PRIMFLOAT      { L _ (ITprimfloat  _) }
 PRIMDOUBLE     { L _ (ITprimdouble _) }

 DOCNEXT        { L _ (ITdocCommentNext _) }
 DOCPREV        { L _ (ITdocCommentPrev _) }
 DOCNAMED       { L _ (ITdocCommentNamed _) }
 DOCSECTION     { L _ (ITdocSection _ _) }
533

534 535 536 537 538
-- Template Haskell
'[|'            { L _ ITopenExpQuote  }
'[p|'           { L _ ITopenPatQuote  }
'[t|'           { L _ ITopenTypQuote  }
'[d|'           { L _ ITopenDecQuote  }
539
'|]'            { L _ ITcloseQuote    }
540 541
'[||'           { L _ ITopenTExpQuote   }
'||]'           { L _ ITcloseTExpQuote  }
542
TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
543
'$('            { L _ ITparenEscape   }     -- $( exp )
544 545
TH_ID_TY_SPLICE { L _ (ITidTyEscape _)  }   -- $$x
'$$('           { L _ ITparenTyEscape   }   -- $$( exp )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
546 547
TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T
TH_QUASIQUOTE   { L _ (ITquasiQuote _) }
548
TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
549 550

%monad { P } { >>= } { return }
Alan Zimmerman's avatar
Alan Zimmerman committed
551
%lexer { (lexer True) } { L _ ITeof }
552 553 554
%tokentype { (Located Token) }

-- Exported parsers
555
%name parseModule module
556 557 558 559 560 561
%name parseImport importdecl
%name parseStatement stmt
%name parseDeclaration topdecl
%name parseExpression exp
%name parseTypeSignature sigdecl
%name parseFullStmt   stmt
562 563
%name parseStmt   maybe_stmt
%name parseIdentifier  identifier
564
%name parseType ctype
565
%partial parseHeader header
566 567
%%

568 569 570
-----------------------------------------------------------------------------
-- Identifiers; one of the entry points
identifier :: { Located RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
571 572 573 574
        : qvar                          { $1 }
        | qcon                          { $1 }
        | qvarop                        { $1 }
        | qconop                        { $1 }
Alan Zimmerman's avatar
Alan Zimmerman committed
575 576
    | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName funTyCon)
                               [mj AnnOpenP $1,mj AnnRarrow $2,mj AnnCloseP $3] }
577

578 579 580 581 582 583 584 585 586 587
-----------------------------------------------------------------------------
-- Module Header

-- The place for module deprecation is really too restrictive, but if it
-- was allowed at its natural place just before 'module', we get an ugly
-- s/r conflict with the second alternative. Another solution would be the
-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,
-- either, and DEPRECATED is only expected to be used by people who really
-- know what they are doing. :-)

Alan Zimmerman's avatar
Alan Zimmerman committed
588 589 590 591 592 593 594
module :: { Located (HsModule RdrName) }
       : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
             {% fileSrcSpan >>= \ loc ->
                ams (L loc (HsModule (Just $3) $5 (fst $ snd $7)
                              (snd $ snd $7) $4 $1)
                    )
                    ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) }
595
        | body2
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
596
                {% fileSrcSpan >>= \ loc ->
Alan Zimmerman's avatar
Alan Zimmerman committed
597 598 599
                   ams (L loc (HsModule Nothing Nothing
                               (fst $ snd $1) (snd $ snd $1) Nothing Nothing))
                       (fst $1) }
600

601
maybedocheader :: { Maybe LHsDocString }
602
        : moduleheader            { $1 }
603
        | {- empty -}             { Nothing }
604 605

missing_module_keyword :: { () }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
606
        : {- empty -}                           {% pushCurrentContext }
607

608
maybemodwarning :: { Maybe (Located WarningTxt) }
Alan Zimmerman's avatar
Alan Zimmerman committed
609
    : '{-# DEPRECATED' strings '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
610 611
                      {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2)))
                             (mo $1:mc $3: (fst $ unLoc $2)) }
Alan Zimmerman's avatar
Alan Zimmerman committed
612
    | '{-# WARNING' strings '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
613
                         {% ajs (Just (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2)))
Alan Zimmerman's avatar
Alan Zimmerman committed
614
                                (mo $1:mc $3 : (fst $ unLoc $2)) }
Ian Lynagh's avatar
Ian Lynagh committed
615
    |  {- empty -}                  { Nothing }
616

Alan Zimmerman's avatar
Alan Zimmerman committed
617 618
body    :: { ([AddAnn]
             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
Alan Zimmerman's avatar
Alan Zimmerman committed
619
        :  '{'            top '}'      { (moc $1:mcc $3:(fst $2)
Alan Zimmerman's avatar
Alan Zimmerman committed
620 621 622 623 624
                                         , snd $2) }
        |      vocurly    top close    { (fst $2, snd $2) }

body2   :: { ([AddAnn]
             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
Alan Zimmerman's avatar
Alan Zimmerman committed
625
        :  '{' top '}'                          { (moc $1:mcc $3
Alan Zimmerman's avatar
Alan Zimmerman committed
626 627 628 629 630
                                                   :(fst $2), snd $2) }
        |  missing_module_keyword top close     { ([],snd $2) }

top     :: { ([AddAnn]
             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
Alan Zimmerman's avatar
Alan Zimmerman committed
631 632 633 634 635 636 637 638 639 640
        : importdecls                   { (fst $1
                                          ,(reverse $ snd $1,[]))}
        | importdecls ';' cvtopdecls    {% if null (snd $1)
                                             then return ((mj AnnSemi $2:(fst $1))
                                                         ,(reverse $ snd $1,$3))
                                             else do
                                              { addAnnotation (gl $ head $ snd $1)
                                                              AnnSemi (gl $2)
                                              ; return (fst $1
                                                       ,(reverse $ snd $1,$3)) }}
Alan Zimmerman's avatar
Alan Zimmerman committed
641
        | cvtopdecls                    { ([],([],$1)) }
642 643

cvtopdecls :: { [LHsDecl RdrName] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
644
        : topdecls                              { cvTopDecls $1 }
645

646 647 648
-----------------------------------------------------------------------------
-- Module declaration & imports only

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
649 650 651
header  :: { Located (HsModule RdrName) }
        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
                {% fileSrcSpan >>= \ loc ->
Alan Zimmerman's avatar
Alan Zimmerman committed
652 653
                   ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
                          )) [mj AnnModule $2,mj AnnWhere $6] }
654
        | header_body2
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
655
                {% fileSrcSpan >>= \ loc ->
656
                   return (L loc (HsModule Nothing Nothing $1 [] Nothing
657
                          Nothing)) }
658 659

header_body :: { [LImportDecl RdrName] }
Alan Zimmerman's avatar
Alan Zimmerman committed
660 661
        :  '{'            importdecls           { snd $2 }
        |      vocurly    importdecls           { snd $2 }
662 663

header_body2 :: { [LImportDecl RdrName] }
Alan Zimmerman's avatar
Alan Zimmerman committed
664 665
        :  '{' importdecls                      { snd $2 }
        |  missing_module_keyword importdecls   { snd $2 }
666

667 668 669
-----------------------------------------------------------------------------
-- The Export List

Alan Zimmerman's avatar
Alan Zimmerman committed
670
maybeexports :: { (Maybe (Located [LIE RdrName])) }
Alan Zimmerman's avatar
Alan Zimmerman committed
671
        :  '(' exportlist ')'       {% ams (sLL $1 $> ()) [mop $1,mcp $3] >>
Alan Zimmerman's avatar
Alan Zimmerman committed
672 673
                                       return (Just (sLL $1 $> (fromOL $2))) }
        |  {- empty -}              { Nothing }
674

675
exportlist :: { OrdList (LIE RdrName) }
Alan Zimmerman's avatar
Alan Zimmerman committed
676 677 678
        : expdoclist ',' expdoclist   {% addAnnotation (oll $1) AnnComma (gl $2)
                                         >> return ($1 `appOL` $3) }
        | exportlist1                 { $1 }
679

680
exportlist1 :: { OrdList (LIE RdrName) }
Alan Zimmerman's avatar
Alan Zimmerman committed
681 682 683 684 685 686
        : expdoclist export expdoclist ',' exportlist1
                          {% (addAnnotation (oll ($1 `appOL` $2 `appOL` $3))
                                            AnnComma (gl $4) ) >>
                              return ($1 `appOL` $2 `appOL` $3 `appOL` $5) }
        | expdoclist export expdoclist             { $1 `appOL` $2 `appOL` $3 }
        | expdoclist                               { $1 }
687

688 689 690
expdoclist :: { OrdList (LIE RdrName) }
        : exp_doc expdoclist                           { $1 `appOL` $2 }
        | {- empty -}                                  { nilOL }
691

692
exp_doc :: { OrdList (LIE RdrName) }
rodlogic's avatar
rodlogic committed
693 694 695
        : docsection    { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) }
        | docnamed      { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) }
        | docnext       { unitOL (sL1 $1 (IEDoc (unLoc $1))) }
696 697


698 699
   -- No longer allow things like [] and (,,,) to be exported
   -- They are built in syntax, always available
700
export  :: { OrdList (LIE RdrName) }
Alan Zimmerman's avatar
Alan Zimmerman committed
701
        : qcname_ext export_subspec  {% amsu (sLL $1 $> (mkModuleImpExp $1
702
                                                    (snd $ unLoc $2)))
Alan Zimmerman's avatar
Alan Zimmerman committed
703 704 705 706 707 708 709 710
                                             (fst $ unLoc $2) }
        |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents $2))
                                             [mj AnnModule $1] }
        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar $2))
                                             [mj AnnPattern $1] }

export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }
        : {- empty -}             { sL0 ([],ImpExpAbs) }
Alan Zimmerman's avatar
Alan Zimmerman committed
711
        | '(' '..' ')'            { sLL $1 $> ([mop $1,mcp $3,mj AnnDotdot $2]
Alan Zimmerman's avatar
Alan Zimmerman committed
712
                                       , ImpExpAll) }
Alan Zimmerman's avatar
Alan Zimmerman committed
713 714
        | '(' ')'                 { sLL $1 $> ([mop $1,mcp $2],ImpExpList []) }
        | '(' qcnames ')'         { sLL $1 $> ([mop $1,mcp $3],ImpExpList (reverse $2)) }
715

716
qcnames :: { [Located RdrName] }     -- A reversed list
Alan Zimmerman's avatar
Alan Zimmerman committed
717 718
        :  qcnames ',' qcname_ext       {% (aa (head $1) (AnnComma, $2)) >>
                                           return ($3  : $1) }
719
        |  qcname_ext                   { [$1]  }
720

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
721 722
qcname_ext :: { Located RdrName }       -- Variable or data constructor
                                        -- or tagged type constructor
Alan Zimmerman's avatar
Alan Zimmerman committed
723
        :  qcname                   { $1 }
724 725
        |  'type' qcname            {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
                                            [mj AnnType $1,mj AnnVal $2] }
726 727

-- Cannot pull into qcname_ext, as qcname is also used in expression.
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
728 729 730
qcname  :: { Located RdrName }  -- Variable or data constructor
        :  qvar                         { $1 }
        |  qcon                         { $1 }
731 732 733 734 735 736 737

-----------------------------------------------------------------------------
-- Import Declarations

-- import decls can be *empty*, or even just a string of semicolons
-- whereas topdecls must contain at least one topdecl.

Alan Zimmerman's avatar
Alan Zimmerman committed
738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753
importdecls :: { ([AddAnn],[LImportDecl RdrName]) }
        : importdecls ';' importdecl
                                {% if null (snd $1)
                                     then return (mj AnnSemi $2:fst $1,$3 : snd $1)
                                     else do
                                      { addAnnotation (gl $ head $ snd $1)
                                                      AnnSemi (gl $2)
                                      ; return (fst $1,$3 : snd $1) } }
        | importdecls ';'       {% if null (snd $1)
                                     then return ((mj AnnSemi $2:fst $1),snd $1)
                                     else do
                                       { addAnnotation (gl $ head $ snd $1)
                                                       AnnSemi (gl $2)
                                       ; return $1} }
        | importdecl             { ([],[$1]) }
        | {- empty -}            { ([],[]) }
754 755

importdecl :: { LImportDecl RdrName }
756
        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
Alan Zimmerman's avatar
Alan Zimmerman committed
757
                {% ams (L (comb4 $1 $6 (snd $7) $8) $
Alan Zimmerman's avatar
Alan Zimmerman committed
758 759
                  ImportDecl { ideclSourceSrc = snd $ fst $2
                             , ideclName = $6, ideclPkgQual = snd $5
Alan Zimmerman's avatar
Alan Zimmerman committed
760 761 762 763
                             , ideclSource = snd $2, ideclSafe = snd $3
                             , ideclQualified = snd $4, ideclImplicit = False
                             , ideclAs = unLoc (snd $7)
                             , ideclHiding = unLoc $8 })
Alan Zimmerman's avatar
Alan Zimmerman committed
764
                   ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4
765
                                    ++ fst $5 ++ fst $7)) }
Alan Zimmerman's avatar
Alan Zimmerman committed
766

Alan Zimmerman's avatar
Alan Zimmerman committed
767 768 769 770
maybe_src :: { (([AddAnn],Maybe SourceText),IsBootInterface) }
        : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],Just (getSOURCE_PRAGs $1))
                                      ,True) }
        | {- empty -}               { (([],Nothing),False) }
Alan Zimmerman's avatar
Alan Zimmerman committed
771 772 773 774 775 776 777 778 779 780 781 782 783 784 785

maybe_safe :: { ([AddAnn],Bool) }
        : 'safe'                                { ([mj AnnSafe $1],True) }
        | {- empty -}                           { ([],False) }

maybe_pkg :: { ([AddAnn],Maybe FastString) }
        : STRING                                { ([mj AnnPackageName $1]
                                                  ,Just (getSTRING $1)) }
        | {- empty -}                           { ([],Nothing) }

optqualified :: { ([AddAnn],Bool) }
        : 'qualified'                           { ([mj AnnQualified $1],True)  }
        | {- empty -}                           { ([],False) }

maybeas :: { ([AddAnn],Located (Maybe ModuleName)) }
786 787 788
        : 'as' modid                           { ([mj AnnAs $1,mj AnnVal $2]
                                                 ,sLL $1 $> (Just (unLoc $2))) }
        | {- empty -}                          { ([],noLoc Nothing) }
789

790
maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) }
Alan Zimmerman's avatar
Alan Zimmerman committed
791 792
        : impspec                  { L (gl $1) (Just (unLoc $1)) }
        | {- empty -}              { noLoc Nothing }
793

794
impspec :: { Located (Bool, Located [LIE RdrName]) }
Alan Zimmerman's avatar
Alan Zimmerman committed
795 796 797 798 799 800
        :  '(' exportlist ')'               {% ams (sLL $1 $> (False,
                                                      sLL $1 $> $ fromOL $2))
                                                   [mop $1,mcp $3] }
        |  'hiding' '(' exportlist ')'      {% ams (sLL $1 $> (True,
                                                      sLL $1 $> $ fromOL $3))
                                               [mj AnnHiding $1,mop $2,mcp $4] }
801 802 803 804

-----------------------------------------------------------------------------
-- Fixity Declarations

805 806 807 808
prec    :: { Located Int }
        : {- empty -}           { noLoc 9 }
        | INTEGER
                 {% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) }
809

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
810
infix   :: { Located FixityDirection }
rodlogic's avatar
rodlogic committed
811 812 813
        : 'infix'                               { sL1 $1 InfixN  }
        | 'infixl'                              { sL1 $1 InfixL  }
        | 'infixr'                              { sL1 $1 InfixR }
814

Alan Zimmerman's avatar
Alan Zimmerman committed
815
ops     :: { Located (OrdList (Located RdrName)) }
Alan Zimmerman's avatar
Alan Zimmerman committed
816 817 818
        : ops ',' op       {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>
                              return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))}
        | op               { sL1 $1 (unitOL $1) }
819 820 821 822

-----------------------------------------------------------------------------
-- Top-Level Declarations

823
topdecls :: { OrdList (LHsDecl RdrName) }
824
        : topdecls ';' topdecl        {% addAnnotation (oll $1) AnnSemi (gl $2)
Alan Zimmerman's avatar
Alan Zimmerman committed
825 826 827 828
                                         >> return ($1 `appOL` $3) }
        | topdecls ';'                {% addAnnotation (oll $1) AnnSemi (gl $2)
                                         >> return $1 }
        | topdecl                     { $1 }
829

830
topdecl :: { OrdList (LHsDecl RdrName) }
rodlogic's avatar
rodlogic committed
831 832 833 834 835
        : cl_decl                               { unitOL (sL1 $1 (TyClD (unLoc $1))) }
        | ty_decl                               { unitOL (sL1 $1 (TyClD (unLoc $1))) }
        | inst_decl                             { unitOL (sL1 $1 (InstD (unLoc $1))) }
        | stand_alone_deriving                  { unitOL (sLL $1 $> (DerivD (unLoc $1))) }
        | role_annot                            { unitOL (sL1 $1 (RoleAnnotD (unLoc $1))) }
thomasw's avatar
thomasw committed
836 837 838
        | 'default' '(' comma_types0 ')'    {% do { def <- checkValidDefaults $3
                                                  ; amsu (sLL $1 $> (DefD def))
                                                         [mj AnnDefault $1
Alan Zimmerman's avatar
Alan Zimmerman committed
839 840 841 842 843 844 845 846 847 848
                                                         ,mop $2,mcp $4] }}
        | 'foreign' fdecl          {% amsu (sLL $1 $> (snd $ unLoc $2))
                                           (mj AnnForeign $1:(fst $ unLoc $2)) }
        | '{-# DEPRECATED' deprecations '#-}'   {% amsu (sLL $1 $> $ WarningD (Warnings (getDEPRECATED_PRAGs $1) (fromOL $2)))
                                                       [mo $1,mc $3] }
        | '{-# WARNING' warnings '#-}'          {% amsu (sLL $1 $> $ WarningD (Warnings (getWARNING_PRAGs $1) (fromOL $2)))
                                                       [mo $1,mc $3] }
        | '{-# RULES' rules '#-}'               {% amsu (sLL $1 $> $ RuleD (HsRules (getRULES_PRAGs $1) (fromOL $2)))
                                                       [mo $1,mc $3] }
        | '{-# VECTORISE' qvar '=' exp '#-}' {% amsu (sLL $1 $> $ VectD (HsVect (getVECT_PRAGs $1) $2 $4))
Alan Zimmerman's avatar
Alan Zimmerman committed
849 850
                                                    [mo $1,mj AnnEqual $3
                                                    ,mc $5] }
Alan Zimmerman's avatar
Alan Zimmerman committed
851
        | '{-# NOVECTORISE' qvar '#-}'       {% amsu (sLL $1 $> $ VectD (HsNoVect (getNOVECT_PRAGs $1) $2))
Alan Zimmerman's avatar
Alan Zimmerman committed
852
                                                     [mo $1,mc $3] }
853
        | '{-# VECTORISE' 'type' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
854
                                {% amsu (sLL $1 $> $
Alan Zimmerman's avatar
Alan Zimmerman committed
855
                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 Nothing))
Alan Zimmerman's avatar
Alan Zimmerman committed
856 857
                                    [mo $1,mj AnnType $2,mc $4] }

858
        | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
859
                                {% amsu (sLL $1 $> $
Alan Zimmerman's avatar
Alan Zimmerman committed
860
                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 Nothing))
Alan Zimmerman's avatar
Alan Zimmerman committed
861 862
                                    [mo $1,mj AnnType $2,mc $4] }

863
        | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
864
                                {% amsu (sLL $1 $> $
Alan Zimmerman's avatar
Alan Zimmerman committed
865
                                    VectD (HsVectTypeIn (getVECT_PRAGs $1) False $3 (Just $5)))
Alan Zimmerman's avatar
Alan Zimmerman committed
866
                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
867
        | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
868
                                {% amsu (sLL $1 $> $
Alan Zimmerman's avatar
Alan Zimmerman committed
869
                                    VectD (HsVectTypeIn (getVECT_SCALAR_PRAGs $1) True $3 (Just $5)))
Alan Zimmerman's avatar
Alan Zimmerman committed
870 871 872
                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }

        | '{-# VECTORISE' 'class' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
873
                                         {% amsu (sLL $1 $>  $ VectD (HsVectClassIn (getVECT_PRAGs $1) $3))
Alan Zimmerman's avatar
Alan Zimmerman committed
874
                                                 [mo $1,mj AnnClass $2,mc $4] }
875
        | annotation { unitOL $1 }
876
        | decl_no_th                            { unLoc $1 }
877 878 879

        -- Template Haskell Extension
        -- The $(..) form is one possible form of infixexp
880
        -- but we treat an arbitrary expression just as if
881
        -- it had a $(..) wrapped around it
rodlogic's avatar
rodlogic committed
882
        | infixexp                              { unitOL (sLL $1 $> $ mkSpliceDecl $1) }
883

884 885 886
-- Type classes
--
cl_decl :: { LTyClDecl RdrName }
887
        : 'class' tycl_hdr fds where_cls
Alan Zimmerman's avatar
Alan Zimmerman committed
888
                {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4))
Alan Zimmerman's avatar
Alan Zimmerman committed
889
                        (mj AnnClass $1:(fst $ unLoc $3)++(fst $ unLoc $4)) }
890

891
-- Type declarations (toplevel)
892 893
--
ty_decl :: { LTyClDecl RdrName }
894
           -- ordinary type synonyms
895
        : 'type' type '=' ctypedoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
896 897 898 899 900 901
                -- Note ctype, not sigtype, on the right of '='
                -- We allow an explicit for-all but we don't insert one
                -- in   type Foo a = (b,b)
                -- Instead we just say b is out of scope
                --
                -- Note the use of type for the head; this allows
902
                -- infix type constructors to be declared
Alan Zimmerman's avatar
Alan Zimmerman committed
903 904
                {% amms (mkTySynonym (comb2 $1 $4) $2 $4)
                        [mj AnnType $1,mj AnnEqual $3] }
905 906

           -- type family declarations
907
        | 'type' 'family' type opt_kind_sig where_type_family
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
908 909
                -- Note the use of type for the head; this allows
                -- infix type constructors to be declared
Alan Zimmerman's avatar
Alan Zimmerman committed
910 911 912
                {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $5) $3
                                   (unLoc $4))
                        (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $5)) }
913

914
          -- ordinary data type or newtype declaration
915
        | data_or_newtype capi_ctype tycl_hdr constrs deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
916 917 918
                {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
                           Nothing (reverse (snd $ unLoc $4))
                                   (unLoc $5))
919
                                   -- We need the location on tycl_hdr in case
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
920
                                   -- constrs and deriving are both empty
Alan Zimmerman's avatar
Alan Zimmerman committed
921
                        ((fst $ unLoc $1):(fst $ unLoc $4)) }
922

923
          -- ordinary GADT declaration
924
        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
925 926
                 gadt_constrlist
                 deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
927 928
            {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
                            (unLoc $4) (snd $ unLoc $5) (unLoc $6) )
929
                                   -- We need the location on tycl_hdr in case
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
930
                                   -- constrs and deriving are both empty
Alan Zimmerman's avatar
Alan Zimmerman committed
931
                    ((fst $ unLoc $1):(fst $ unLoc $5)) }
932

933
          -- data/newtype family
934
        | 'data' 'family' type opt_kind_sig
Alan Zimmerman's avatar
Alan Zimmerman committed
935 936
                {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4))
                        [mj AnnData $1,mj AnnFamily $2] }
937

938
inst_decl :: { LInstDecl RdrName }
939
        : 'instance' overlap_pragma inst_type where_inst
Alan Zimmerman's avatar
Alan Zimmerman committed
940 941 942 943 944
       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)
             ; let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds
                                     , cid_sigs = sigs, cid_tyfam_insts = ats
                                     , cid_overlap_mode = $2
                                     , cid_datafam_insts = adts }
thomasw's avatar
thomasw committed
945 946
             ; let err = text "In instance head:" <+> ppr $3
             ; checkNoPartialType err $3
947 948 949 950
             ; sequence_ [ checkNoPartialType err ty
                         | sig@(L _ (TypeSig _ ty _ )) <- sigs
                         , let err = text "in instance signature" <> colon
                                     <+> quotes (ppr sig) ]
Alan Zimmerman's avatar
Alan Zimmerman committed
951 952
             ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }))
                   (mj AnnInstance $1 : (fst $ unLoc $4)) } }
953 954

           -- type instance declarations
955
        | 'type' 'instance' ty_fam_inst_eqn
Alan Zimmerman's avatar
Alan Zimmerman committed
956 957
                {% amms (mkTyFamInst (comb2 $1 $3) $3)
                    [mj AnnType $1,mj AnnInstance $2] }
958

959
          -- data/newtype instance declaration
960
        | data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
961 962 963 964
            {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 $4
                                      Nothing (reverse (snd  $ unLoc $5))
                                              (unLoc $6))
                    ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }
965

966
          -- GADT instance declaration
967
        | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
968 969
                 gadt_constrlist
                 deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
970 971 972 973
            {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 $4
                                   (unLoc $5) (snd $ unLoc $6) (unLoc $7))
                    ((fst $ unLoc $1):mj AnnInstance $2
                       :(fst $ unLoc $6)) }
974

975
overlap_pragma :: { Maybe (Located OverlapMode) }
Alan Zimmerman's avatar
Alan Zimmerman committed
976
  : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))))
Alan Zimmerman's avatar
Alan Zimmerman committed
977
                                       [mo $1,mc $2] }
Alan Zimmerman's avatar
Alan Zimmerman committed
978
  | '{-# OVERLAPPING'     '#-}' {% ajs (Just (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))))
Alan Zimmerman's avatar
Alan Zimmerman committed
979
                                       [mo $1,mc $2] }
Alan Zimmerman's avatar
Alan Zimmerman committed
980
  | '{-# OVERLAPS'        '#-}' {% ajs (Just (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))))
Alan Zimmerman's avatar
Alan Zimmerman committed
981
                                       [mo $1,mc $2] }
Alan Zimmerman's avatar
Alan Zimmerman committed
982
  | '{-# INCOHERENT'      '#-}' {% ajs (Just (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))))
Alan Zimmerman's avatar
Alan Zimmerman committed
983
                                       [mo $1,mc $2] }
984
  | {- empty -}                 { Nothing }
985 986


987 988
-- Closed type families

Alan Zimmerman's avatar
Alan Zimmerman committed
989 990
where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) }
        : {- empty -}                      { noLoc ([],OpenTypeFamily) }
991
        | 'where' ty_fam_inst_eqn_list
Alan Zimmerman's avatar
Alan Zimmerman committed
992 993 994 995
               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
                    ,ClosedTypeFamily (reverse (snd $ unLoc $2))) }

ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) }
Alan Zimmerman's avatar
Alan Zimmerman committed
996
        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]
Alan Zimmerman's avatar
Alan Zimmerman committed
997 998 999
                                                ,unLoc $2) }
        | vocurly ty_fam_inst_eqns close   { let L loc _ = $2 in
                                             L loc ([],unLoc $2) }
Alan Zimmerman's avatar
Alan Zimmerman committed
1000 1001
        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2
                                                 ,mcc $3],[]) }
Alan Zimmerman's avatar
Alan Zimmerman committed
1002 1003
        | vocurly '..' close               { let L loc _ = $2 in
                                             L loc ([mj AnnDotdot $2],[]) }
1004 1005

ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
Alan Zimmerman's avatar
Alan Zimmerman committed
1006
        : ty_fam_inst_eqns ';' ty_fam_inst_eqn
1007
                                      {% asl (unLoc $1) $2 $3
Alan Zimmerman's avatar
Alan Zimmerman committed
1008 1009 1010 1011
                                         >> return (sLL $1 $> ($3 : unLoc $1)) }
        | ty_fam_inst_eqns ';'        {% addAnnotation (gl $1) AnnSemi (gl $2)
                                         >> return (sLL $1 $>  (unLoc $1)) }
        | ty_fam_inst_eqn             { sLL $1 $> [$1] }
1012 1013 1014 1015 1016

ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
        : type '=' ctype
                -- Note the use of type for the head; this allows
                -- infix type constructors and type patterns
Alan Zimmerman's avatar
Alan Zimmerman committed
1017 1018
              {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
                    ; ams (sLL $1 $> eqn) (mj AnnEqual $2:ann) } }
1019

1020
-- Associated type family declarations
1021 1022 1023 1024 1025 1026
--
-- * They have a different syntax than on the toplevel (no family special
--   identifier).
--
-- * They also need to be separate from instances; otherwise, data family
--   declarations without a kind signature cause parsing conflicts with empty
1027
--   data declarations.
1028
--
1029
at_decl_cls :: { LHsDecl RdrName }
1030 1031
        :  -- data family declarations, with optional 'family' keyword
          'data' opt_family type opt_kind_sig
Alan Zimmerman's avatar
Alan Zimmerman committed
1032 1033 1034
                {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3
                                                  (unLoc $4)))
                        (mj AnnData $1:$2) }
1035