Parser.y 144 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 31 32 33 34 35 36 37
-- | 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
--       parseState = mkPState flags buffer location in
-- @
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
}

{-
90 91 92 93 94 95 96 97 98 99 100 101
-----------------------------------------------------------------------------
20 Nov 2014

Conflicts: 60 shift/reduce
           12 reduce/reduce

-----------------------------------------------------------------------------
25 June 2014

Conflicts: 47 shift/reduce
           1 reduce/reduce

102
-----------------------------------------------------------------------------
Gabor Greif's avatar
Gabor Greif committed
103 104 105 106 107 108 109
12 October 2012

Conflicts: 43 shift/reduce
           1 reduce/reduce

-----------------------------------------------------------------------------
24 February 2006
110 111 112 113 114 115 116 117 118

Conflicts: 33 shift/reduce
           1 reduce/reduce

The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
would think the two should never occur in the same context.

  -=chak

119 120 121 122 123
-----------------------------------------------------------------------------
31 December 2006

Conflicts: 34 shift/reduce
           1 reduce/reduce
Alan Zimmerman's avatar
Alan Zimmerman committed
124
q
125 126 127 128 129
The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
would think the two should never occur in the same context.

  -=chak

130 131 132 133 134 135 136 137 138 139 140
-----------------------------------------------------------------------------
6 December 2006

Conflicts: 32 shift/reduce
           1 reduce/reduce

The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
would think the two should never occur in the same context.

  -=chak

141 142 143 144 145 146 147 148 149 150 151
-----------------------------------------------------------------------------
26 July 2006

Conflicts: 37 shift/reduce
           1 reduce/reduce

The reduce/reduce conflict is weird.  It's between tyconsym and consym, and I
would think the two should never occur in the same context.

  -=chak

152
-----------------------------------------------------------------------------
153
Conflicts: 38 shift/reduce (1.25)
154

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
155 156 157
10 for abiguity in 'if x then y else z + 1'             [State 178]
        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
        10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM
158

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
159 160
1 for ambiguity in 'if x then y else z :: T'            [State 178]
        (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
161

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
162 163 164
4 for ambiguity in 'if x then y else z -< e'            [State 178]
        (shift parses as 'if x then y else (z -< T)', as per longest-parse rule)
        There are four such operators: -<, >-, -<<, >>-
165 166


chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
167 168 169 170
2 for ambiguity in 'case v of { x :: T -> T ... } '     [States 11, 253]
        Which of these two is intended?
          case v of
            (x::T) -> T         -- Rhs is T
171
    or
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
172 173
          case v of
            (x::T -> T) -> ..   -- Rhs is ...
ross's avatar
ross committed
174

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
175
10 for ambiguity in 'e :: a `b` c'.  Does this mean     [States 11, 253]
176
        (e::a) `b` c, or
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
177
        (e :: (a `b` c))
178
    As well as `b` we can have !, VARSYM, QCONSYM, and CONSYM, hence 5 cases
179
    Same duplication between states 11 and 253 as the previous case
180

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
181 182 183 184
1 for ambiguity in 'let ?x ...'                         [State 329]
        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.
185

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
186 187 188 189
1 for ambiguity in '{-# RULES "name" [ ... #-}          [State 382]
        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
190

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
191 192 193 194 195 196 197
1 for ambiguity in '{-# RULES "name" forall = ... #-}'  [State 474]
        since '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'.
198

199 200
1 for ambiguity when the source file starts with "-- | doc". We need another
  token of lookahead to determine if a top declaration or the 'module' keyword
201
  follows. Shift parses as if the 'module' keyword follows.
202

203 204 205
-- ---------------------------------------------------------------------------
-- Adding location info

rodlogic's avatar
rodlogic committed
206 207 208 209
This is done using the three functions below, sL0, sL1
and sLL.  Note that these functions were mechanically
converted from the three macros that used to exist before,
namely L0, L1 and LL.
210 211 212

They each add a SrcSpan to their argument.

rodlogic's avatar
rodlogic committed
213
   sL0  adds 'noSrcSpan', used for empty productions
214
     -- This doesn't seem to work anymore -=chak
215

rodlogic's avatar
rodlogic committed
216
   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
217
        from that token.
218

rodlogic's avatar
rodlogic committed
219
   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from
220 221 222
        the first and last tokens.

These suffice for the majority of cases.  However, we must be
rodlogic's avatar
rodlogic committed
223
especially careful with empty productions: sLL won't work if the first
224 225 226
or last token on the lhs can represent an empty span.  In these cases,
we have to calculate the span using more of the tokens from the lhs, eg.

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
227 228
        | 'newtype' tycl_hdr '=' newconstr deriving
                { L (comb3 $1 $4 $5)
Alan Zimmerman's avatar
Alan Zimmerman committed
229
                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }
230 231 232 233 234 235 236

We provide comb3 and comb4 functions which are useful in such cases.

Be careful: there's no checking that you actually got this right, the
only symptom will be that the SrcSpans of your syntax will be
incorrect.

237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
-- -----------------------------------------------------------------------------
-- API Annotations

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.

See https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations for some background.

252 253 254 255 256
-- -----------------------------------------------------------------------------

-}

%token
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
257 258
 '_'            { L _ ITunderscore }            -- Haskell keywords
 'as'           { L _ ITas }
259 260 261
 'case'         { L _ ITcase }
 'class'        { L _ ITclass }
 'data'         { L _ ITdata }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285
 '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 }
286
 'label'        { L _ ITlabel }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
287 288
 'dynamic'      { L _ ITdynamic }
 'safe'         { L _ ITsafe }
289
 'interruptible' { L _ ITinterruptible }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
290 291 292
 'unsafe'       { L _ ITunsafe }
 'mdo'          { L _ ITmdo }
 'family'       { L _ ITfamily }
293
 'role'         { L _ ITrole }
294 295
 'stdcall'      { L _ ITstdcallconv }
 'ccall'        { L _ ITccallconv }
296
 'capi'         { L _ ITcapiconv }
297
 'prim'         { L _ ITprimcallconv }
thoughtpolice's avatar
thoughtpolice committed
298
 'javascript'   { L _ ITjavascriptcallconv }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
299 300
 'proc'         { L _ ITproc }          -- for arrow notation extension
 'rec'          { L _ ITrec }           -- for arrow notation extension
301 302 303
 '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
304
 'pattern'      { L _ ITpattern } -- for pattern synonyms
Facundo Domínguez's avatar
Facundo Domínguez committed
305
 'static'       { L _ ITstatic }  -- for static pointers extension
306

307 308
 '{-# INLINE'             { L _ (ITinline_prag _ _) }
 '{-# SPECIALISE'         { L _ ITspec_prag }
309
 '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
310 311 312
 '{-# SOURCE'                                   { L _ ITsource_prag }
 '{-# RULES'                                    { L _ ITrules_prag }
 '{-# CORE'                                     { L _ ITcore_prag }              -- hdaume: annotated core
313 314 315 316 317
 '{-# SCC'                { L _ ITscc_prag }
 '{-# GENERATED'          { L _ ITgenerated_prag }
 '{-# DEPRECATED'         { L _ ITdeprecated_prag }
 '{-# WARNING'            { L _ ITwarning_prag }
 '{-# UNPACK'             { L _ ITunpack_prag }
318
 '{-# NOUNPACK'           { L _ ITnounpack_prag }
319
 '{-# ANN'                { L _ ITann_prag }
320 321
 '{-# VECTORISE'          { L _ ITvect_prag }
 '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
322
 '{-# NOVECTORISE'        { L _ ITnovect_prag }
323
 '{-# MINIMAL'            { L _ ITminimal_prag }
324
 '{-# CTYPE'              { L _ ITctype }
325 326 327
 '{-# OVERLAPPING'        { L _ IToverlapping_prag }
 '{-# OVERLAPPABLE'       { L _ IToverlappable_prag }
 '{-# OVERLAPS'           { L _ IToverlaps_prag }
328
 '{-# INCOHERENT'         { L _ ITincoherent_prag }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
329 330 331 332 333 334 335
 '#-}'                                          { L _ ITclose_prag }

 '..'           { L _ ITdotdot }                        -- reserved symbols
 ':'            { L _ ITcolon }
 '::'           { L _ ITdcolon }
 '='            { L _ ITequal }
 '\\'           { L _ ITlam }
336
 'lcase'        { L _ ITlcase }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
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 364 365 366 367 368 369
 '|'            { 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
370
 SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
371 372 373 374 375 376 377 378 379

 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  _) }
380 381
 PREFIXQVARSYM  { L _ (ITprefixqvarsym  _) }
 PREFIXQCONSYM  { L _ (ITprefixqconsym  _) }
382

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

385 386 387
 CHAR           { L _ (ITchar   _ _) }
 STRING         { L _ (ITstring _ _) }
 INTEGER        { L _ (ITinteger _ _) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
388
 RATIONAL       { L _ (ITrational _) }
389

390 391 392 393
 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
394 395 396 397 398 399 400
 PRIMFLOAT      { L _ (ITprimfloat  _) }
 PRIMDOUBLE     { L _ (ITprimdouble _) }

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

402 403 404 405 406
-- Template Haskell
'[|'            { L _ ITopenExpQuote  }
'[p|'           { L _ ITopenPatQuote  }
'[t|'           { L _ ITopenTypQuote  }
'[d|'           { L _ ITopenDecQuote  }
407
'|]'            { L _ ITcloseQuote    }
408 409
'[||'           { L _ ITopenTExpQuote   }
'||]'           { L _ ITcloseTExpQuote  }
410
TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
411
'$('            { L _ ITparenEscape   }     -- $( exp )
412 413
TH_ID_TY_SPLICE { L _ (ITidTyEscape _)  }   -- $$x
'$$('           { L _ ITparenTyEscape   }   -- $$( exp )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
414 415
TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T
TH_QUASIQUOTE   { L _ (ITquasiQuote _) }
416
TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
417 418

%monad { P } { >>= } { return }
Alan Zimmerman's avatar
Alan Zimmerman committed
419
%lexer { (lexer True) } { L _ ITeof }
420 421 422
%tokentype { (Located Token) }

-- Exported parsers
423
%name parseModule module
424 425 426 427 428 429
%name parseImport importdecl
%name parseStatement stmt
%name parseDeclaration topdecl
%name parseExpression exp
%name parseTypeSignature sigdecl
%name parseFullStmt   stmt
430 431
%name parseStmt   maybe_stmt
%name parseIdentifier  identifier
432
%name parseType ctype
433
%partial parseHeader header
434 435
%%

436 437 438
-----------------------------------------------------------------------------
-- Identifiers; one of the entry points
identifier :: { Located RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
439 440 441 442
        : qvar                          { $1 }
        | qcon                          { $1 }
        | qvarop                        { $1 }
        | qconop                        { $1 }
rodlogic's avatar
rodlogic committed
443
    | '(' '->' ')'      { sLL $1 $> $ getRdrName funTyCon }
444

445 446 447 448 449 450 451 452 453 454
-----------------------------------------------------------------------------
-- 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
455 456 457 458 459 460 461
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) }
462
        | body2
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
463
                {% fileSrcSpan >>= \ loc ->
Alan Zimmerman's avatar
Alan Zimmerman committed
464 465 466
                   ams (L loc (HsModule Nothing Nothing
                               (fst $ snd $1) (snd $ snd $1) Nothing Nothing))
                       (fst $1) }
467

468
maybedocheader :: { Maybe LHsDocString }
469
        : moduleheader            { $1 }
470
        | {- empty -}             { Nothing }
471 472

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

475
maybemodwarning :: { Maybe (Located WarningTxt) }
Alan Zimmerman's avatar
Alan Zimmerman committed
476 477 478 479 480 481
    : '{-# DEPRECATED' strings '#-}'
                      {% ajs (Just (sLL $1 $> $ DeprecatedTxt $ snd $ unLoc $2))
                             (mo $1:mc $1: (fst $ unLoc $2)) }
    | '{-# WARNING' strings '#-}'
                         {% ajs (Just (sLL $1 $> $ WarningTxt $ snd $ unLoc $2))
                                (mo $1:mc $3 : (fst $ unLoc $2)) }
Ian Lynagh's avatar
Ian Lynagh committed
482
    |  {- empty -}                  { Nothing }
483

Alan Zimmerman's avatar
Alan Zimmerman committed
484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502
body    :: { ([AddAnn]
             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
        :  '{'            top '}'      { (mo $1:mc $3:(fst $2)
                                         , snd $2) }
        |      vocurly    top close    { (fst $2, snd $2) }

body2   :: { ([AddAnn]
             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
        :  '{' top '}'                          { (mo $1:mc $3
                                                   :(fst $2), snd $2) }
        |  missing_module_keyword top close     { ([],snd $2) }

top     :: { ([AddAnn]
             ,([LImportDecl RdrName], [LHsDecl RdrName])) }
        : importdecls                   { ([]
                                          ,(reverse $1,[]))}
        | importdecls ';' cvtopdecls    { ([mj AnnSemi $2]
                                          ,(reverse $1,$3))}
        | cvtopdecls                    { ([],([],$1)) }
503 504

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

507 508 509
-----------------------------------------------------------------------------
-- Module declaration & imports only

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
510 511 512
header  :: { Located (HsModule RdrName) }
        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
                {% fileSrcSpan >>= \ loc ->
Alan Zimmerman's avatar
Alan Zimmerman committed
513 514
                   ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1
                          )) [mj AnnModule $2,mj AnnWhere $6] }
515
        | header_body2
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
516
                {% fileSrcSpan >>= \ loc ->
517
                   return (L loc (HsModule Nothing Nothing $1 [] Nothing
518
                          Nothing)) }
519 520

header_body :: { [LImportDecl RdrName] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
521
        :  '{'            importdecls           { $2 }
522 523 524 525 526
        |      vocurly    importdecls           { $2 }

header_body2 :: { [LImportDecl RdrName] }
        :  '{' importdecls                      { $2 }
        |  missing_module_keyword importdecls   { $2 }
527

528 529 530
-----------------------------------------------------------------------------
-- The Export List

Alan Zimmerman's avatar
Alan Zimmerman committed
531 532 533 534
maybeexports :: { (Maybe (Located [LIE RdrName])) }
        :  '(' exportlist ')'       {% ams (sLL $1 $> ()) [mo $1,mc $3] >>
                                       return (Just (sLL $1 $> (fromOL $2))) }
        |  {- empty -}              { Nothing }
535

536
exportlist :: { OrdList (LIE RdrName) }
Alan Zimmerman's avatar
Alan Zimmerman committed
537 538 539
        : expdoclist ',' expdoclist   {% addAnnotation (oll $1) AnnComma (gl $2)
                                         >> return ($1 `appOL` $3) }
        | exportlist1                 { $1 }
540

541
exportlist1 :: { OrdList (LIE RdrName) }
Alan Zimmerman's avatar
Alan Zimmerman committed
542 543 544 545 546 547
        : 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 }
548

549 550 551
expdoclist :: { OrdList (LIE RdrName) }
        : exp_doc expdoclist                           { $1 `appOL` $2 }
        | {- empty -}                                  { nilOL }
552

553
exp_doc :: { OrdList (LIE RdrName) }
rodlogic's avatar
rodlogic committed
554 555 556
        : 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))) }
557 558


559 560
   -- No longer allow things like [] and (,,,) to be exported
   -- They are built in syntax, always available
561
export  :: { OrdList (LIE RdrName) }
Alan Zimmerman's avatar
Alan Zimmerman committed
562
        : qcname_ext export_subspec  {% amsu (sLL $1 $> (mkModuleImpExp $1
563
                                                    (snd $ unLoc $2)))
Alan Zimmerman's avatar
Alan Zimmerman committed
564 565 566 567 568 569 570 571 572 573 574 575
                                             (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) }
        | '(' '..' ')'            { sLL $1 $> ([mo $1,mc $3,mj AnnDotdot $2]
                                       , ImpExpAll) }
        | '(' ')'                 { sLL $1 $> ([mo $1,mc $2],ImpExpList []) }
        | '(' qcnames ')'         { sLL $1 $> ([mo $1,mc $3],ImpExpList (reverse $2)) }
576

577
qcnames :: { [Located RdrName] }     -- A reversed list
Alan Zimmerman's avatar
Alan Zimmerman committed
578 579
        :  qcnames ',' qcname_ext       {% (aa (head $1) (AnnComma, $2)) >>
                                           return ($3  : $1) }
580
        |  qcname_ext                   { [$1]  }
581

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
582 583
qcname_ext :: { Located RdrName }       -- Variable or data constructor
                                        -- or tagged type constructor
584 585 586
        :  qcname                   {% ams $1 [mj AnnVal $1] }
        |  'type' qcname            {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2)))
                                            [mj AnnType $1,mj AnnVal $2] }
587 588

-- 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
589 590 591
qcname  :: { Located RdrName }  -- Variable or data constructor
        :  qvar                         { $1 }
        |  qcon                         { $1 }
592 593 594 595 596 597 598 599

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

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

importdecls :: { [LImportDecl RdrName] }
600
        : importdecls ';' importdecl  {% (asl $1 $2 $3) >>
Alan Zimmerman's avatar
Alan Zimmerman committed
601 602 603 604 605 606
                                         return ($3 : $1) }
        | importdecls ';'        {% addAnnotation (gl $ head $1) AnnSemi (gl $2)
              -- AZ: can $1 above ever be [] due to the {- empty -} production?
                                    >> return $1 }
        | importdecl             { [$1] }
        | {- empty -}            { [] }
607 608

importdecl :: { LImportDecl RdrName }
609
        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
Alan Zimmerman's avatar
Alan Zimmerman committed
610 611 612 613 614 615 616
                {% ams (L (comb4 $1 $6 (snd $7) $8) $
                  ImportDecl { ideclName = $6, ideclPkgQual = snd $5
                             , ideclSource = snd $2, ideclSafe = snd $3
                             , ideclQualified = snd $4, ideclImplicit = False
                             , ideclAs = unLoc (snd $7)
                             , ideclHiding = unLoc $8 })
                   ((mj AnnImport $1 : fst $2 ++ fst $3 ++ fst $4
617
                                    ++ fst $5 ++ fst $7)) }
Alan Zimmerman's avatar
Alan Zimmerman committed
618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636

maybe_src :: { ([AddAnn],IsBootInterface) }
        : '{-# SOURCE' '#-}'           { ([mo $1,mc $2],True) }
        | {- empty -}                  { ([],False) }

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)) }
637 638 639
        : 'as' modid                           { ([mj AnnAs $1,mj AnnVal $2]
                                                 ,sLL $1 $> (Just (unLoc $2))) }
        | {- empty -}                          { ([],noLoc Nothing) }
640

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

645
impspec :: { Located (Bool, Located [LIE RdrName]) }
Alan Zimmerman's avatar
Alan Zimmerman committed
646 647 648 649 650 651
        :  '(' exportlist ')'                 {% ams (sLL $1 $> (False,
                                                        sLL $1 $> $ fromOL $2))
                                                      [mo $1,mc $3] }
        |  'hiding' '(' exportlist ')'        {% ams (sLL $1 $> (True,
                                                        sLL $1 $> $ fromOL $3))
                                                 [mj AnnHiding $1,mo $2,mc $4] }
652 653 654 655

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

656 657 658 659
prec    :: { Located Int }
        : {- empty -}           { noLoc 9 }
        | INTEGER
                 {% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) }
660

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
661
infix   :: { Located FixityDirection }
rodlogic's avatar
rodlogic committed
662 663 664
        : 'infix'                               { sL1 $1 InfixN  }
        | 'infixl'                              { sL1 $1 InfixL  }
        | 'infixr'                              { sL1 $1 InfixR }
665

Alan Zimmerman's avatar
Alan Zimmerman committed
666 667 668 669
ops     :: { Located (OrdList (Located RdrName)) }
        : ops ',' op              {% addAnnotation (gl $3) AnnComma (gl $2) >>
                                     return (sLL $1 $> (unitOL $3 `appOL` (unLoc $1)))}
        | op                      { sL1 $1 (unitOL $1) }
670 671 672 673

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

674
topdecls :: { OrdList (LHsDecl RdrName) }
675
        : topdecls ';' topdecl        {% addAnnotation (oll $1) AnnSemi (gl $2)
Alan Zimmerman's avatar
Alan Zimmerman committed
676 677 678 679
                                         >> return ($1 `appOL` $3) }
        | topdecls ';'                {% addAnnotation (oll $1) AnnSemi (gl $2)
                                         >> return $1 }
        | topdecl                     { $1 }
680

681
topdecl :: { OrdList (LHsDecl RdrName) }
rodlogic's avatar
rodlogic committed
682 683 684 685 686
        : 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
687 688 689 690
        | 'default' '(' comma_types0 ')'    {% do { def <- checkValidDefaults $3
                                                  ; amsu (sLL $1 $> (DefD def))
                                                         [mj AnnDefault $1
                                                         ,mo $2,mc $4] }}
Alan Zimmerman's avatar
Alan Zimmerman committed
691 692 693 694 695 696 697 698 699 700
        | 'foreign' fdecl                       {% amsu (sLL $1 $> (unLoc $2))
                                                        [mj AnnForeign $1] }
        | '{-# DEPRECATED' deprecations '#-}'   { $2 } -- ++AZ++ TODO
        | '{-# WARNING' warnings '#-}'          { $2 } -- ++AZ++ TODO
        | '{-# RULES' rules '#-}'               { $2 } -- ++AZ++ TODO
        | '{-# VECTORISE' qvar '=' exp '#-}' {% amsu (sLL $1 $> $ VectD (HsVect $2 $4))
                                                    [mo $1,mj AnnEqual $3
                                                    ,mc $5] }
        | '{-# NOVECTORISE' qvar '#-}'       {% amsu (sLL $1 $> $ VectD (HsNoVect $2))
                                                     [mo $1,mc $3] }
701
        | '{-# VECTORISE' 'type' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
702 703 704 705
                                {% amsu (sLL $1 $> $
                                    VectD (HsVectTypeIn False $3 Nothing))
                                    [mo $1,mj AnnType $2,mc $4] }

706
        | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
707 708 709 710
                                {% amsu (sLL $1 $> $
                                    VectD (HsVectTypeIn True $3 Nothing))
                                    [mo $1,mj AnnType $2,mc $4] }

711
        | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
712 713 714
                                {% amsu (sLL $1 $> $
                                    VectD (HsVectTypeIn False $3 (Just $5)))
                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
715
        | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
716 717 718 719 720 721 722
                                {% amsu (sLL $1 $> $
                                    VectD (HsVectTypeIn True $3 (Just $5)))
                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }

        | '{-# VECTORISE' 'class' gtycon '#-}'
                                         {% amsu (sLL $1 $>  $ VectD (HsVectClassIn $3))
                                                 [mo $1,mj AnnClass $2,mc $4] }
723
        | annotation { unitOL $1 }
724
        | decl_no_th                            { unLoc $1 }
725 726 727

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

732 733 734
-- Type classes
--
cl_decl :: { LTyClDecl RdrName }
735
        : 'class' tycl_hdr fds where_cls
Alan Zimmerman's avatar
Alan Zimmerman committed
736 737
                {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (snd $ unLoc $4))
                        (mj AnnClass $1: (fst $ unLoc $4)) }
738

739
-- Type declarations (toplevel)
740 741
--
ty_decl :: { LTyClDecl RdrName }
742
           -- ordinary type synonyms
743
        : 'type' type '=' ctypedoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
744 745 746 747 748 749
                -- 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
750
                -- infix type constructors to be declared
Alan Zimmerman's avatar
Alan Zimmerman committed
751 752
                {% amms (mkTySynonym (comb2 $1 $4) $2 $4)
                        [mj AnnType $1,mj AnnEqual $3] }
753 754

           -- type family declarations
755
        | 'type' 'family' type opt_kind_sig where_type_family
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
756 757
                -- Note the use of type for the head; this allows
                -- infix type constructors to be declared
Alan Zimmerman's avatar
Alan Zimmerman committed
758 759 760
                {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $5) $3
                                   (unLoc $4))
                        (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $5)) }
761

762
          -- ordinary data type or newtype declaration
763
        | data_or_newtype capi_ctype tycl_hdr constrs deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
764 765 766
                {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
                           Nothing (reverse (snd $ unLoc $4))
                                   (unLoc $5))
767
                                   -- We need the location on tycl_hdr in case
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
768
                                   -- constrs and deriving are both empty
Alan Zimmerman's avatar
Alan Zimmerman committed
769
                        ((fst $ unLoc $1):(fst $ unLoc $4)) }
770

771
          -- ordinary GADT declaration
772
        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
773 774
                 gadt_constrlist
                 deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
775 776
            {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3
                            (unLoc $4) (snd $ unLoc $5) (unLoc $6) )
777
                                   -- We need the location on tycl_hdr in case
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
778
                                   -- constrs and deriving are both empty
Alan Zimmerman's avatar
Alan Zimmerman committed
779
                    ((fst $ unLoc $1):(fst $ unLoc $5)) }
780

781
          -- data/newtype family
782
        | 'data' 'family' type opt_kind_sig
Alan Zimmerman's avatar
Alan Zimmerman committed
783 784
                {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4))
                        [mj AnnData $1,mj AnnFamily $2] }
785

786
inst_decl :: { LInstDecl RdrName }
787
        : 'instance' overlap_pragma inst_type where_inst
Alan Zimmerman's avatar
Alan Zimmerman committed
788 789 790 791 792
       {% 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
793 794
             ; let err = text "In instance head:" <+> ppr $3
             ; checkNoPartialType err $3
Alan Zimmerman's avatar
Alan Zimmerman committed
795 796
             ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }))
                   (mj AnnInstance $1 : (fst $ unLoc $4)) } }
797 798

           -- type instance declarations
799
        | 'type' 'instance' ty_fam_inst_eqn
Alan Zimmerman's avatar
Alan Zimmerman committed
800 801
                {% amms (mkTyFamInst (comb2 $1 $3) $3)
                    [mj AnnType $1,mj AnnInstance $2] }
802

803
          -- data/newtype instance declaration
804
        | data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
805 806 807 808
            {% 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)) }
809

810
          -- GADT instance declaration
811
        | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
812 813
                 gadt_constrlist
                 deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
814 815 816 817
            {% 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)) }
818

819
overlap_pragma :: { Maybe (Located OverlapMode) }
Alan Zimmerman's avatar
Alan Zimmerman committed
820 821 822 823 824 825 826 827
  : '{-# OVERLAPPABLE'    '#-}' {% ajs (Just (sLL $1 $> Overlappable))
                                       [mo $1,mc $2] }
  | '{-# OVERLAPPING'     '#-}' {% ajs (Just (sLL $1 $> Overlapping))
                                       [mo $1,mc $2] }
  | '{-# OVERLAPS'        '#-}' {% ajs (Just (sLL $1 $> Overlaps))
                                       [mo $1,mc $2] }
  | '{-# INCOHERENT'      '#-}' {% ajs (Just (sLL $1 $> Incoherent))
                                       [mo $1,mc $2] }
828
  | {- empty -}                 { Nothing }
829 830


831 832
-- Closed type families

Alan Zimmerman's avatar
Alan Zimmerman committed
833 834
where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) }
        : {- empty -}                      { noLoc ([],OpenTypeFamily) }
835
        | 'where' ty_fam_inst_eqn_list
Alan Zimmerman's avatar
Alan Zimmerman committed
836 837 838 839 840 841 842 843 844 845 846 847
               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)
                    ,ClosedTypeFamily (reverse (snd $ unLoc $2))) }

ty_fam_inst_eqn_list :: { Located ([AddAnn],[LTyFamInstEqn RdrName]) }
        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([mo $1,mc $3]
                                                ,unLoc $2) }
        | vocurly ty_fam_inst_eqns close   { let L loc _ = $2 in
                                             L loc ([],unLoc $2) }
        |     '{' '..' '}'                 { sLL $1 $> ([mo $1,mj AnnDotdot $2
                                                 ,mc $3],[]) }
        | vocurly '..' close               { let L loc _ = $2 in
                                             L loc ([mj AnnDotdot $2],[]) }
848 849

ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
Alan Zimmerman's avatar
Alan Zimmerman committed
850
        : ty_fam_inst_eqns ';' ty_fam_inst_eqn
851
                                      {% asl (unLoc $1) $2 $3
Alan Zimmerman's avatar
Alan Zimmerman committed
852 853 854 855
                                         >> 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] }
856 857 858 859 860

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

864
-- Associated type family declarations
865 866 867 868 869 870
--
-- * 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
871
--   data declarations.
872
--
873
at_decl_cls :: { LHsDecl RdrName }
874 875
        :  -- data family declarations, with optional 'family' keyword
          'data' opt_family type opt_kind_sig
Alan Zimmerman's avatar
Alan Zimmerman committed
876 877 878
                {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3
                                                  (unLoc $4)))
                        (mj AnnData $1:$2) }
879 880 881 882

           -- type family declarations, with optional 'family' keyword
           -- (can't use opt_instance because you get shift/reduce errors
        | 'type' type opt_kind_sig
Alan Zimmerman's avatar
Alan Zimmerman committed
883 884 885
               {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $2 $3)
                                                  OpenTypeFamily $2 (unLoc $3)))
                       [mj AnnType $1] }
886
        | 'type' 'family' type opt_kind_sig
Alan Zimmerman's avatar
Alan Zimmerman committed
887 888 889
               {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4)
                                                  OpenTypeFamily $3 (unLoc $4)))
                       [mj AnnType $1,mj AnnFamily $2] }
890 891

           -- default type instances, with optional 'instance' keyword
892
        | 'type' ty_fam_inst_eqn
Alan Zimmerman's avatar
Alan Zimmerman committed
893 894
                {% amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) $2))
                        [mj AnnType $1] }
895
        | 'type' 'instance' ty_fam_inst_eqn
Alan Zimmerman's avatar
Alan Zimmerman committed
896 897
                {% amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) $3))
                        [mj AnnType $1,mj AnnInstance $2] }
898

Alan Zimmerman's avatar
Alan Zimmerman committed
899 900 901
opt_family   :: { [AddAnn] }
              : {- empty -}   { [] }
              | 'family'      { [mj AnnFamily $1] }
902 903

-- Associated type instances
904
--
905
at_decl_inst :: { LInstDecl RdrName }
906
           -- type instance declarations
907
        : 'type' ty_fam_inst_eqn
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 and type patterns
Alan Zimmerman's avatar
Alan Zimmerman committed
910 911
                {% amms (mkTyFamInst (comb2 $1 $2) $2)
                        [mj AnnType $1] }
912 913

        -- data/newtype instance declaration
914
        | data_or_newtype capi_ctype tycl_hdr constrs deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
915 916 917 918
               {% amms (mkDataFamInst (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3
                                    Nothing (reverse (snd $ unLoc $4))
                                            (unLoc $5))
                       ((fst $ unLoc $1):(fst $ unLoc $4)) }
919 920

        -- GADT instance declaration
921
        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
922 923
                 gadt_constrlist
                 deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
924 925 926
                {% amms (mkDataFamInst (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2
                                $3 (unLoc $4) (snd $ unLoc $5) (unLoc $6))
                        ((fst $ unLoc $1):(fst $ unLoc $5)) }
927

Alan Zimmerman's avatar
Alan Zimmerman committed
928 929 930
data_or_newtype :: { Located (AddAnn,NewOrData) }
        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }
        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }
931

932
opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
Alan Zimmerman's avatar
Alan Zimmerman committed
933 934
        :                             { noLoc Nothing }
        | '::' kind                   {% ajl (sLL $1 $> (Just $2)) AnnDcolon (gl $1) }
935

936
-- tycl_hdr parses the header of a class or data type decl,
937
-- which takes the form
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
938 939 940 941
--      T a b
--      Eq a => T a
--      (Eq a, Ord b) => T a b
--      T Int [a]                       -- for associated types
942
-- Rather a lot of inlining here, else we get reduce/reduce errors
943
tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
Alan Zimmerman's avatar
Alan Zimmerman committed
944 945 946 947 948 949
        : context '=>' type         {% return (L (comb2 $1 $2) (unLoc $1))
                                       >>= \c@(L l _) ->
                                         (addAnnotation l AnnDarrow (gl $2))
                                       >> (return (sLL $1 $> (Just c, $3)))
                                    }
        | type                      { sL1 $1 (Nothing, $1) }
950

951 952
capi_ctype :: { Maybe (Located CType) }
capi_ctype : '{-# CTYPE' STRING STRING '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
953 954 955 956
                       {% ajs (Just (sLL $1 $> (CType (Just (Header (getSTRING $2)))
                                        (getSTRING $3))))
                              [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }

957
           | '{-# CTYPE'        STRING '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
958 959 960 961
                       {% ajs (Just (sLL $1 $> (CType Nothing  (getSTRING $2))))
                              [mo $1,mj AnnVal $2,mc $3] }

           |           { Nothing }
962

963 964 965 966 967
-----------------------------------------------------------------------------
-- Stand-alone deriving

-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
Alan Zimmerman's avatar
Alan Zimmerman committed
968 969 970
  : 'deriving' 'instance' overlap_pragma inst_type
                         {% ams (sLL $1 $> (DerivDecl $4 $3))
                                [mj AnnDeriving $1,mj AnnInstance $2] }
971

972 973 974 975 976
-----------------------------------------------------------------------------
-- Role annotations

role_annot :: { LRoleAnnotDecl RdrName }
role_annot : 'type' 'role' oqtycon maybe_roles
Alan Zimmerman's avatar
Alan Zimmerman committed
977 978
          {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4)))
                  [mj AnnType $1,mj AnnRole $2] }
979 980 981 982 983 984 985

-- Reversed!
maybe_roles :: { Located [Located (Maybe FastString)] }
maybe_roles : {- empty -}    { noLoc [] }
            | roles          { $1 }

roles :: { Located [Located (Maybe FastString)] }
rodlogic's avatar
rodlogic committed
986 987
roles : role             { sLL $1 $> [$1] }
      | roles role       { sLL $1 $> $ $2 : unLoc $1 }
988 989 990

-- read it in as a varid for better error messages
role :: { Located (Maybe FastString) }
rodlogic's avatar
rodlogic committed
991 992
role : VARID             { sL1 $1 $ Just $ getVARID $1 }
     | '_'               { sL1 $1 Nothing }
993

cactus's avatar
cactus committed
994 995 996 997
-- Pattern synonyms

-- Glasgow extension: pattern synonyms
pattern_synonym_decl :: { LHsDecl RdrName }
998
        : 'pattern' pattern_synonym_lhs '=' pat
Alan Zimmerman's avatar
Alan Zimmerman committed
999 1000 1001 1002 1003
         {%ams ( let (name, args) = $2
                 in sLL $1 $> . ValD $ mkPatSynBind name args $4
                                                    ImplicitBidirectional)
               [mj AnnPattern $1,mj AnnEqual $3]
         }
1004
        | 'pattern' pattern_synonym_lhs '<-' pat
Alan Zimmerman's avatar
Alan Zimmerman committed
1005 1006 1007
         {%ams (let (name, args) = $2
                in sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional)
               [mj AnnPattern $1,mj AnnLarrow $3] }
1008 1009
        | 'pattern' pattern_synonym_lhs '<-' pat where_decls
            {% do { let (name, args) = $2
Alan Zimmerman's avatar
Alan Zimmerman committed
1010 1011 1012 1013 1014
                  ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)
                  ; ams (sLL $1 $> . ValD $
                           mkPatSynBind name args $4 (ExplicitBidirectional mg))
                        (mj AnnPattern $1:mj AnnLarrow $3:(fst $ unLoc $5))
                   }}
1015

1016 1017 1018
pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName)) }
        : con vars0 { ($1, PrefixPatSyn $2) }
        | varid consym varid { ($2, InfixPatSyn $1 $3) }
cactus's avatar
cactus committed
1019 1020 1021 1022 1023

vars0 :: { [Located RdrName] }
        : {- empty -}                 { [] }
        | varid vars0                 { $1 : $2 }

Alan Zimmerman's avatar
Alan Zimmerman committed
1024 1025 1026 1027 1028 1029
where_decls :: { Located ([AddAnn]
                         , Located (OrdList (LHsDecl RdrName))) }
        : 'where' '{' decls '}'       { sLL $1 $> ([mj AnnWhere $1,mo $2
                                            ,mc $4],$3) }
        | 'where' vocurly decls close { L (comb2 $1 $3) ([mj AnnWhere $1]
                                          ,$3) }
1030 1031
pattern_synonym_sig :: { LSig RdrName }
        : 'pattern' con '::' ptype
1032
            {% do { let (flag, qtvs, prov, req, ty) = snd $ unLoc $4
thomasw's avatar
thomasw committed
1033 1034
                  ; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty
                  ; checkValidPatSynSig sig
1035 1036
                  ; ams (sLL $1 $> $ sig)
                        (mj AnnPattern $1:mj AnnDcolon $3:(fst $ unLoc $4)) } }