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
305

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

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

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

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

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

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

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

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

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

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

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

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

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

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

474
maybemodwarning :: { Maybe (Located WarningTxt) }
Alan Zimmerman's avatar
Alan Zimmerman committed
475 476 477 478 479 480
    : '{-# 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
481
    |  {- empty -}                  { Nothing }
482

Alan Zimmerman's avatar
Alan Zimmerman committed
483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501
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)) }
502 503

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

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

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

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

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

527 528 529
-----------------------------------------------------------------------------
-- The Export List

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

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

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

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

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


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

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

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

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

-----------------------------------------------------------------------------
-- 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] }
599
        : importdecls ';' importdecl  {% (asl $1 $2 $3) >>
Alan Zimmerman's avatar
Alan Zimmerman committed
600 601 602 603 604 605
                                         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 -}            { [] }
606 607

importdecl :: { LImportDecl RdrName }
608
        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec
Alan Zimmerman's avatar
Alan Zimmerman committed
609 610 611 612 613 614 615
                {% 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
616
                                    ++ fst $5 ++ fst $7)) }
Alan Zimmerman's avatar
Alan Zimmerman committed
617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635

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

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

644
impspec :: { Located (Bool, Located [LIE RdrName]) }
Alan Zimmerman's avatar
Alan Zimmerman committed
645 646 647 648 649 650
        :  '(' 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] }
651 652 653 654

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

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

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

Alan Zimmerman's avatar
Alan Zimmerman committed
665 666 667 668
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) }
669 670 671 672

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

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

680
topdecl :: { OrdList (LHsDecl RdrName) }
rodlogic's avatar
rodlogic committed
681 682 683 684 685
        : 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
686 687 688 689
        | '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
690 691 692 693 694 695 696 697 698 699
        | '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] }
700
        | '{-# VECTORISE' 'type' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
701 702 703 704
                                {% amsu (sLL $1 $> $
                                    VectD (HsVectTypeIn False $3 Nothing))
                                    [mo $1,mj AnnType $2,mc $4] }

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

710
        | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
711 712 713
                                {% amsu (sLL $1 $> $
                                    VectD (HsVectTypeIn False $3 (Just $5)))
                                    [mo $1,mj AnnType $2,mj AnnEqual $4,mc $6] }
714
        | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
Alan Zimmerman's avatar
Alan Zimmerman committed
715 716 717 718 719 720 721
                                {% 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] }
722
        | annotation { unitOL $1 }
723
        | decl_no_th                            { unLoc $1 }
724 725 726

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

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

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

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

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

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

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

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

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

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

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

818
overlap_pragma :: { Maybe (Located OverlapMode) }
Alan Zimmerman's avatar
Alan Zimmerman committed
819 820 821 822 823 824 825 826
  : '{-# 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] }
827
  | {- empty -}                 { Nothing }
828 829


830 831
-- Closed type families

Alan Zimmerman's avatar
Alan Zimmerman committed
832 833
where_type_family :: { Located ([AddAnn],FamilyInfo RdrName) }
        : {- empty -}                      { noLoc ([],OpenTypeFamily) }
834
        | 'where' ty_fam_inst_eqn_list
Alan Zimmerman's avatar
Alan Zimmerman committed
835 836 837 838 839 840 841 842 843 844 845 846
               { 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],[]) }
847 848

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

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

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

           -- 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
882 883 884
               {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $2 $3)
                                                  OpenTypeFamily $2 (unLoc $3)))
                       [mj AnnType $1] }
885
        | 'type' 'family' type opt_kind_sig
Alan Zimmerman's avatar
Alan Zimmerman committed
886 887 888
               {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4)
                                                  OpenTypeFamily $3 (unLoc $4)))
                       [mj AnnType $1,mj AnnFamily $2] }
889 890

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

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

-- Associated type instances
903
--
904
at_decl_inst :: { LInstDecl RdrName }
905
           -- type instance declarations
906
        : 'type' ty_fam_inst_eqn
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
907 908
                -- Note the use of type for the head; this allows
                -- infix type constructors and type patterns
Alan Zimmerman's avatar
Alan Zimmerman committed
909 910
                {% amms (mkTyFamInst (comb2 $1 $2) $2)
                        [mj AnnType $1] }
911 912

        -- data/newtype instance declaration
913
        | data_or_newtype capi_ctype tycl_hdr constrs deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
914 915 916 917
               {% 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)) }
918 919

        -- GADT instance declaration
920
        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
921 922
                 gadt_constrlist
                 deriving
Alan Zimmerman's avatar
Alan Zimmerman committed
923 924 925
                {% 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)) }
926

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

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

935
-- tycl_hdr parses the header of a class or data type decl,
936
-- which takes the form
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
937 938 939 940
--      T a b
--      Eq a => T a
--      (Eq a, Ord b) => T a b
--      T Int [a]                       -- for associated types
941
-- Rather a lot of inlining here, else we get reduce/reduce errors
942
tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
Alan Zimmerman's avatar
Alan Zimmerman committed
943 944 945 946 947 948
        : 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) }
949

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

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

           |           { Nothing }
961

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

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

971 972 973 974 975
-----------------------------------------------------------------------------
-- Role annotations

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

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

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

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

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

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

1015 1016 1017
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
1018 1019 1020 1021 1022

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

Alan Zimmerman's avatar
Alan Zimmerman committed
1023 1024 1025 1026 1027 1028
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) }
1029 1030
pattern_synonym_sig :: { LSig RdrName }
        : 'pattern' con '::' ptype
1031
            {% do { let (flag, qtvs, prov, req, ty) = snd $ unLoc $4
thomasw's avatar
thomasw committed
1032 1033
                  ; let sig = PatSynSig $2 (flag, mkHsQTvs qtvs) prov req ty
                  ; checkValidPatSynSig sig
1034 1035
                  ; ams (sLL $1 $> $ sig)
                        (mj AnnPattern $1:mj AnnDcolon $3:(fst $ unLoc $4)) } }
1036