Parser.y.pp 93.4 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 16 17 18
-- 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
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

19 20 21 22 23 24 25 26
{-# OPTIONS_GHC -O0 -fno-ignore-interface-pragmas #-}
{-
Careful optimisation of the parser: we don't want to throw everything
at it, because that takes too long and doesn't buy much, but we do want
to inline certain key external functions, so we instruct GHC not to
throw away inlinings as it would normally do in -O0 mode.
-}

27
module Parser ( parseModule, parseStmt, parseIdentifier, parseType,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
28
                parseHeader ) where
29 30 31

import HsSyn
import RdrHsSyn
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
32
import HscTypes         ( IsBootInterface, WarningTxt(..) )
33 34
import Lexer
import RdrName
35
import TcEvidence       ( emptyTcEvBinds )
dreixel's avatar
dreixel committed
36
import TysPrim          ( liftedTypeKindTyConName, eqPrimTyCon )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
37
import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
38
                          unboxedUnitTyCon, unboxedUnitDataCon,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
39 40
                          listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
import Type             ( funTyCon )
41
import ForeignCall
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
42 43
import OccName          ( varName, dataName, tcClsName, tvName )
import DataCon          ( DataCon, dataConName )
Ian Lynagh's avatar
Ian Lynagh committed
44
import SrcLoc
45
import Module
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
46
import StaticFlags      ( opt_SccProfilingOn, opt_Hpc )
dreixel's avatar
dreixel committed
47
import Kind             ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
48
import Class            ( FunDep )
49
import BasicTypes
50
import DynFlags
51
import OrdList
52
import HaddockUtils
53 54

import FastString
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
55
import Maybes           ( orElse )
56
import Outputable
57

58
import Control.Monad    ( unless )
Simon Marlow's avatar
Simon Marlow committed
59
import GHC.Exts
60 61
import Data.Char
import Control.Monad    ( mplus )
62 63 64
}

{-
65 66 67 68 69 70 71 72 73 74 75
-----------------------------------------------------------------------------
24 Februar 2006

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

76 77 78 79 80 81 82 83 84 85 86
-----------------------------------------------------------------------------
31 December 2006

Conflicts: 34 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

87 88 89 90 91 92 93 94 95 96 97
-----------------------------------------------------------------------------
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

98 99 100 101 102 103 104 105 106 107 108
-----------------------------------------------------------------------------
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

109
-----------------------------------------------------------------------------
110
Conflicts: 38 shift/reduce (1.25)
111

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
112 113 114
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
115

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
116 117
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)
118

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
119 120 121
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: -<, >-, -<<, >>-
122 123


chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
124 125 126 127
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
128
    or
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
129 130
          case v of
            (x::T -> T) -> ..   -- Rhs is ...
131

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

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
138 139 140 141
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.
142

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
143 144 145 146
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
147

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
148 149 150 151 152 153 154
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'.
155

156 157 158 159
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
  follows. Shift parses as if the 'module' keyword follows.   

160 161 162 163 164 165 166 167 168 169
-- ---------------------------------------------------------------------------
-- Adding location info

This is done in a stylised way using the three macros below, L0, L1
and LL.  Each of these macros can be thought of as having type

   L0, L1, LL :: a -> Located a

They each add a SrcSpan to their argument.

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
170
   L0   adds 'noSrcSpan', used for empty productions
171
     -- This doesn't seem to work anymore -=chak
172 173

   L1   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
174
        from that token.
175 176 177 178 179 180 181 182 183

   LL   for a production with >1 token on the lhs.  Makes up a SrcSpan from
        the first and last tokens.

These suffice for the majority of cases.  However, we must be
especially careful with empty productions: LL won't work if the first
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
184 185 186
        | 'newtype' tycl_hdr '=' newconstr deriving
                { L (comb3 $1 $4 $5)
                    (mkTyData NewType (unLoc $2) [$4] (unLoc $5)) }
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206

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.

/*
 * We must expand these macros *before* running Happy, which is why this file is
 * Parser.y.pp rather than just Parser.y - we run the C pre-processor first.
 */
#define L0   L noSrcSpan
#define L1   sL (getLoc $1)
#define LL   sL (comb2 $1 $>)

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

-}

%token
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
 '_'            { L _ ITunderscore }            -- Haskell keywords
 'as'           { L _ ITas }
 'case'         { L _ ITcase }          
 'class'        { L _ ITclass } 
 'data'         { L _ ITdata } 
 '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 }
 '_scc_'        { L _ ITscc }         -- ToDo: remove

 'forall'       { L _ ITforall }                -- GHC extension keywords
 'foreign'      { L _ ITforeign }
 'export'       { L _ ITexport }
 'label'        { L _ ITlabel } 
 'dynamic'      { L _ ITdynamic }
 'safe'         { L _ ITsafe }
240
 'interruptible' { L _ ITinterruptible }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
241 242 243
 'unsafe'       { L _ ITunsafe }
 'mdo'          { L _ ITmdo }
 'family'       { L _ ITfamily }
244 245
 'stdcall'      { L _ ITstdcallconv }
 'ccall'        { L _ ITccallconv }
246
 'capi'         { L _ ITcapiconv }
247
 'prim'         { L _ ITprimcallconv }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
248 249
 'proc'         { L _ ITproc }          -- for arrow notation extension
 'rec'          { L _ ITrec }           -- for arrow notation extension
250 251 252
 'group'    { L _ ITgroup }     -- for list transform extension
 'by'       { L _ ITby }        -- for list transform extension
 'using'    { L _ ITusing }     -- for list transform extension
253

254 255
 '{-# INLINE'             { L _ (ITinline_prag _ _) }
 '{-# SPECIALISE'         { L _ ITspec_prag }
256
 '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
257 258 259
 '{-# SOURCE'                                   { L _ ITsource_prag }
 '{-# RULES'                                    { L _ ITrules_prag }
 '{-# CORE'                                     { L _ ITcore_prag }              -- hdaume: annotated core
260 261 262 263 264
 '{-# SCC'                { L _ ITscc_prag }
 '{-# GENERATED'          { L _ ITgenerated_prag }
 '{-# DEPRECATED'         { L _ ITdeprecated_prag }
 '{-# WARNING'            { L _ ITwarning_prag }
 '{-# UNPACK'             { L _ ITunpack_prag }
265
 '{-# NOUNPACK'           { L _ ITnounpack_prag }
266
 '{-# ANN'                { L _ ITann_prag }
267 268
 '{-# VECTORISE'          { L _ ITvect_prag }
 '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
269
 '{-# NOVECTORISE'        { L _ ITnovect_prag }
270
 '{-# CTYPE'              { L _ ITctype }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
 '#-}'                                          { L _ ITclose_prag }

 '..'           { L _ ITdotdot }                        -- reserved symbols
 ':'            { L _ ITcolon }
 '::'           { L _ ITdcolon }
 '='            { L _ ITequal }
 '\\'           { L _ ITlam }
 '|'            { 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
311
 SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
312 313 314 315 316 317 318 319 320

 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  _) }
321 322
 PREFIXQVARSYM  { L _ (ITprefixqvarsym  _) }
 PREFIXQCONSYM  { L _ (ITprefixqconsym  _) }
323

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
 IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension

 CHAR           { L _ (ITchar     _) }
 STRING         { L _ (ITstring   _) }
 INTEGER        { L _ (ITinteger  _) }
 RATIONAL       { L _ (ITrational _) }
                    
 PRIMCHAR       { L _ (ITprimchar   _) }
 PRIMSTRING     { L _ (ITprimstring _) }
 PRIMINTEGER    { L _ (ITprimint    _) }
 PRIMWORD       { L _ (ITprimword  _) }
 PRIMFLOAT      { L _ (ITprimfloat  _) }
 PRIMDOUBLE     { L _ (ITprimdouble _) }

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

343 344 345 346 347 348 349
-- Template Haskell 
'[|'            { L _ ITopenExpQuote  }       
'[p|'           { L _ ITopenPatQuote  }      
'[t|'           { L _ ITopenTypQuote  }      
'[d|'           { L _ ITopenDecQuote  }      
'|]'            { L _ ITcloseQuote    }
TH_ID_SPLICE    { L _ (ITidEscape _)  }     -- $x
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
350 351 352
'$('            { L _ ITparenEscape   }     -- $( exp )
TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T
TH_QUASIQUOTE   { L _ (ITquasiQuote _) }
353 354 355 356 357 358

%monad { P } { >>= } { return }
%lexer { lexer } { L _ ITeof }
%name parseModule module
%name parseStmt   maybe_stmt
%name parseIdentifier  identifier
359
%name parseType ctype
360
%partial parseHeader header
361
%tokentype { (Located Token) }
362 363
%%

364 365 366
-----------------------------------------------------------------------------
-- Identifiers; one of the entry points
identifier :: { Located RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
367 368 369 370
        : qvar                          { $1 }
        | qcon                          { $1 }
        | qvarop                        { $1 }
        | qconop                        { $1 }
371
    | '(' '->' ')'      { LL $ getRdrName funTyCon }
372

373 374 375 376 377 378 379 380 381 382
-----------------------------------------------------------------------------
-- 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. :-)

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
383 384 385 386
module  :: { Located (HsModule RdrName) }
        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 $1
387
                          ) )}
388
        | body2
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
389 390
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule Nothing Nothing
391 392
                          (fst $1) (snd $1) Nothing Nothing
                          )) }
393

394
maybedocheader :: { Maybe LHsDocString }
395
        : moduleheader            { $1 }
396
        | {- empty -}             { Nothing }
397 398

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

Ian Lynagh's avatar
Ian Lynagh committed
401
maybemodwarning :: { Maybe WarningTxt }
402 403
    : '{-# DEPRECATED' strings '#-}' { Just (DeprecatedTxt $ unLoc $2) }
    | '{-# WARNING' strings '#-}'    { Just (WarningTxt $ unLoc $2) }
Ian Lynagh's avatar
Ian Lynagh committed
404
    |  {- empty -}                  { Nothing }
405

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
406 407 408
body    :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
        :  '{'            top '}'               { $2 }
        |      vocurly    top close             { $2 }
409

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
410 411 412
body2   :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
        :  '{' top '}'                          { $2 }
        |  missing_module_keyword top close     { $2 }
413

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
414 415 416 417
top     :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
        : importdecls                           { (reverse $1,[]) }
        | importdecls ';' cvtopdecls            { (reverse $1,$3) }
        | cvtopdecls                            { ([],$1) }
418 419

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

422 423 424
-----------------------------------------------------------------------------
-- Module declaration & imports only

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
425 426 427 428
header  :: { Located (HsModule RdrName) }
        : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
                {% fileSrcSpan >>= \ loc ->
                   return (L loc (HsModule (Just $3) $5 $7 [] $4 $1
429
                          ))}
430
        | header_body2
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
431
                {% fileSrcSpan >>= \ loc ->
432
                   return (L loc (HsModule Nothing Nothing $1 [] Nothing
433
                          Nothing)) }
434 435

header_body :: { [LImportDecl RdrName] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
436
        :  '{'            importdecls           { $2 }
437 438 439 440 441
        |      vocurly    importdecls           { $2 }

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

443 444 445 446
-----------------------------------------------------------------------------
-- The Export List

maybeexports :: { Maybe [LIE RdrName] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
447 448
        :  '(' exportlist ')'                   { Just $2 }
        |  {- empty -}                          { Nothing }
449

450
exportlist :: { [LIE RdrName] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
451 452
        : expdoclist ',' expdoclist             { $1 ++ $3 }
        | exportlist1                           { $1 }
453 454

exportlist1 :: { [LIE RdrName] }
455
        : expdoclist export expdoclist ',' exportlist  { $1 ++ ($2 : $3) ++ $5 }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
456 457
        | expdoclist export expdoclist                 { $1 ++ ($2 : $3) }
        | expdoclist                                   { $1 }
458 459 460 461 462 463 464 465 466

expdoclist :: { [LIE RdrName] }
        : exp_doc expdoclist                           { $1 : $2 }
        | {- empty -}                                  { [] }

exp_doc :: { LIE RdrName }                                                   
        : docsection    { L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc) }
        | docnamed      { L1 (IEDocNamed ((fst . unLoc) $1)) } 
        | docnext       { L1 (IEDoc (unLoc $1)) }       
467 468


469 470
   -- No longer allow things like [] and (,,,) to be exported
   -- They are built in syntax, always available
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
471
export  :: { LIE RdrName }
472 473
        : qcname_ext export_subspec     { LL (mkModuleImpExp (unLoc $1)
                                                             (unLoc $2)) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
474
        |  'module' modid               { LL (IEModuleContents (unLoc $2)) }
475

476 477 478 479
export_subspec :: { Located ImpExpSubSpec }
        : {- empty -}                   { L0 ImpExpAbs }
        | '(' '..' ')'                  { LL ImpExpAll }
        | '(' ')'                       { LL (ImpExpList []) }
480
        | '(' qcnames ')'               { LL (ImpExpList (reverse $2)) }
481

482
qcnames :: { [RdrName] }     -- A reversed list
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
483 484
        :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
        |  qcname_ext                   { [unLoc $1]  }
485

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
486 487 488
qcname_ext :: { Located RdrName }       -- Variable or data constructor
                                        -- or tagged type constructor
        :  qcname                       { $1 }
489
        |  'type' qcname                {% mkTypeImpExp (LL (unLoc $2)) }
490 491

-- 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
492 493 494
qcname  :: { Located RdrName }  -- Variable or data constructor
        :  qvar                         { $1 }
        |  qcon                         { $1 }
495 496 497 498 499 500 501 502

-----------------------------------------------------------------------------
-- 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] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
503 504 505 506
        : importdecls ';' importdecl            { $3 : $1 }
        | importdecls ';'                       { $1 }
        | importdecl                            { [ $1 ] }
        | {- empty -}                           { [] }
507 508

importdecl :: { LImportDecl RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
509 510
        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec 
                { L (comb4 $1 $6 $7 $8) $
511 512 513 514
                  ImportDecl { ideclName = $6, ideclPkgQual = $5
                             , ideclSource = $2, ideclSafe = $3
                             , ideclQualified = $4, ideclImplicit = False
                             , ideclAs = unLoc $7, ideclHiding = unLoc $8 } }
515 516

maybe_src :: { IsBootInterface }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
517 518
        : '{-# SOURCE' '#-}'                    { True }
        | {- empty -}                           { False }
519

520
maybe_safe :: { Bool }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
521 522
        : 'safe'                                { True }
        | {- empty -}                           { False }
523

524 525 526 527
maybe_pkg :: { Maybe FastString }
        : STRING                                { Just (getSTRING $1) }
        | {- empty -}                           { Nothing }

528
optqualified :: { Bool }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
529 530
        : 'qualified'                           { True  }
        | {- empty -}                           { False }
531

Simon Marlow's avatar
Simon Marlow committed
532
maybeas :: { Located (Maybe ModuleName) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
533 534
        : 'as' modid                            { LL (Just (unLoc $2)) }
        | {- empty -}                           { noLoc Nothing }
535 536

maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
537 538
        : impspec                               { L1 (Just (unLoc $1)) }
        | {- empty -}                           { noLoc Nothing }
539 540

impspec :: { Located (Bool, [LIE RdrName]) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
541 542
        :  '(' exportlist ')'                   { LL (False, $2) }
        |  'hiding' '(' exportlist ')'          { LL (True,  $3) }
543 544 545 546

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

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
547 548 549
prec    :: { Int }
        : {- empty -}           { 9 }
        | INTEGER               {% checkPrecP (L1 (fromInteger (getINTEGER $1))) }
550

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
551 552 553 554
infix   :: { Located FixityDirection }
        : 'infix'                               { L1 InfixN  }
        | 'infixl'                              { L1 InfixL  }
        | 'infixr'                              { L1 InfixR }
555

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
556 557 558
ops     :: { Located [Located RdrName] }
        : ops ',' op                            { LL ($3 : unLoc $1) }
        | op                                    { L1 [$1] }
559 560 561 562

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

563
topdecls :: { OrdList (LHsDecl RdrName) }
564 565 566
        : topdecls ';' topdecl                  { $1 `appOL` $3 }
        | topdecls ';'                          { $1 }
        | topdecl                               { $1 }
567

568
topdecl :: { OrdList (LHsDecl RdrName) }
569 570
        : cl_decl                               { unitOL (L1 (TyClD (unLoc $1))) }
        | ty_decl                               { unitOL (L1 (TyClD (unLoc $1))) }
571
        | inst_decl                             { unitOL (L1 (InstD (unLoc $1))) }
572
        | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
573 574
        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
575 576
        | '{-# DEPRECATED' deprecations '#-}'   { $2 }
        | '{-# WARNING' warnings '#-}'          { $2 }
577
        | '{-# RULES' rules '#-}'               { $2 }
578 579 580
        | '{-# VECTORISE_SCALAR' qvar '#-}'     { unitOL $ LL $ VectD (HsVect       $2 Nothing) }
        | '{-# VECTORISE' qvar '=' exp '#-}'    { unitOL $ LL $ VectD (HsVect       $2 (Just $4)) }
        | '{-# NOVECTORISE' qvar '#-}'          { unitOL $ LL $ VectD (HsNoVect     $2) }
581 582 583 584 585 586 587 588 589
        | '{-# VECTORISE' 'type' gtycon '#-}'     
                                                { unitOL $ LL $ 
                                                    VectD (HsVectTypeIn False $3 Nothing) }
        | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'     
                                                { unitOL $ LL $ 
                                                    VectD (HsVectTypeIn True $3 Nothing) }
        | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'     
                                                { unitOL $ LL $ 
                                                    VectD (HsVectTypeIn False $3 (Just $5)) }
590 591 592
        | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'     
                                                { unitOL $ LL $ 
                                                    VectD (HsVectTypeIn True $3 (Just $5)) }
593 594
        | '{-# VECTORISE' 'class' gtycon '#-}'  { unitOL $ LL $ VectD (HsVectClassIn $3) }
        | '{-# VECTORISE_SCALAR' 'instance' type '#-}'     
595
                                                { unitOL $ LL $ VectD (HsVectInstIn $3) }
596 597 598 599 600 601 602 603
        | annotation { unitOL $1 }
        | decl                                  { unLoc $1 }

        -- Template Haskell Extension
        -- The $(..) form is one possible form of infixexp
        -- but we treat an arbitrary expression just as if 
        -- it had a $(..) wrapped around it
        | infixexp                              { unitOL (LL $ mkTopSpliceDecl $1) } 
604

605 606 607
-- Type classes
--
cl_decl :: { LTyClDecl RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
608
        : 'class' tycl_hdr fds where_cls        {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 }
609

610
-- Type declarations (toplevel)
611 612
--
ty_decl :: { LTyClDecl RdrName }
613
           -- ordinary type synonyms
614
        : 'type' type '=' ctypedoc
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
615 616 617 618 619 620 621
                -- 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
                -- infix type constructors to be declared 
622
                {% mkTySynonym (comb2 $1 $4) $2 $4 }
623 624

           -- type family declarations
625
        | 'type' 'family' type opt_kind_sig 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
626 627 628
                -- Note the use of type for the head; this allows
                -- infix type constructors to be declared
                {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
629

630
          -- ordinary data type or newtype declaration
631
        | data_or_newtype capi_ctype tycl_hdr constrs deriving
632
                {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 
633
                            Nothing (reverse (unLoc $4)) (unLoc $5) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
634 635
                                   -- We need the location on tycl_hdr in case 
                                   -- constrs and deriving are both empty
636

637
          -- ordinary GADT declaration
638
        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
639 640
                 gadt_constrlist
                 deriving
641
                {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 
642
                            (unLoc $4) (unLoc $5) (unLoc $6) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
643 644
                                   -- We need the location on tycl_hdr in case 
                                   -- constrs and deriving are both empty
645

646
          -- data/newtype family
647
        | 'data' 'family' type opt_kind_sig
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
648
                {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
649

650 651
inst_decl :: { LInstDecl RdrName }
        : 'instance' inst_type where_inst
652 653
                 { let (binds, sigs, _, ats, _) = cvBindsAndSigs (unLoc $3)
                   in L (comb3 $1 $2 $3) (ClsInstD $2 binds sigs ats) }
654 655

           -- type instance declarations
656
        | 'type' 'instance' type '=' ctype
657 658
                -- Note the use of type for the head; this allows
                -- infix type constructors and type patterns
659 660
                {% do { L loc d <- mkFamInstSynonym (comb2 $1 $5) $3 $5
                      ; return (L loc (FamInstD d)) } }
661

662
          -- data/newtype instance declaration
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
663
        | data_or_newtype 'instance' tycl_hdr constrs deriving
664
                {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3
665
                                      Nothing (reverse (unLoc $4)) (unLoc $5)
666
                      ; return (L loc (FamInstD d)) } }
667

668
          -- GADT instance declaration
669
        | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
670 671
                 gadt_constrlist
                 deriving
672
                {% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3
673
                                            (unLoc $4) (unLoc $5) (unLoc $6)
674
                      ; return (L loc (FamInstD d)) } }
675
        
676
-- Associated type family declarations
677 678 679 680 681 682 683
--
-- * 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
--   data declarations. 
684
--
685 686
at_decl_cls :: { LHsDecl RdrName }
           -- family declarations
687
        : 'type' type opt_kind_sig
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
688
                -- Note the use of type for the head; this allows
689
                -- infix type constructors to be declared.
690 691 692 693 694 695
                {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3)
                      ; return (L loc (TyClD decl)) } }

        | 'data' type opt_kind_sig
                {% do { L loc decl <- mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3)
                      ; return (L loc (TyClD decl)) } }
696

697
           -- default type instance
698
        | 'type' type '=' ctype
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
699 700
                -- Note the use of type for the head; this allows
                -- infix type constructors and type patterns
701 702
                {% do { L loc fid <- mkFamInstSynonym (comb2 $1 $4) $2 $4
                      ; return (L loc (InstD (FamInstD fid))) } }
703 704

-- Associated type instances
705
--
706
at_decl_inst :: { LFamInstDecl RdrName }
707
           -- type instance declarations
708
        : 'type' type '=' ctype
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
709 710
                -- Note the use of type for the head; this allows
                -- infix type constructors and type patterns
711
                {% mkFamInstSynonym (comb2 $1 $4) $2 $4 }
712 713

        -- data/newtype instance declaration
714
        | data_or_newtype capi_ctype tycl_hdr constrs deriving
715 716
                {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 
                                 Nothing (reverse (unLoc $4)) (unLoc $5) }
717 718

        -- GADT instance declaration
719
        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
720 721
                 gadt_constrlist
                 deriving
722 723
                {% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 
                                 (unLoc $4) (unLoc $5) (unLoc $6) }
724

725
data_or_newtype :: { Located NewOrData }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
726 727
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }
728

729
opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
730
        :                               { noLoc Nothing }
731
        | '::' kind                     { LL (Just (HsBSig $2 placeHolderBndrs)) }
732

733
-- tycl_hdr parses the header of a class or data type decl,
734
-- which takes the form
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
735 736 737 738
--      T a b
--      Eq a => T a
--      (Eq a, Ord b) => T a b
--      T Int [a]                       -- for associated types
739
-- Rather a lot of inlining here, else we get reduce/reduce errors
740
tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
741 742
        : context '=>' type             { LL (Just $1, $3) }
        | type                          { L1 (Nothing, $1) }
743

744
capi_ctype :: { Maybe CType }
745 746
capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) }
           | '{-# CTYPE'        STRING '#-}' { Just (CType Nothing                        (getSTRING $2)) }
747
           |                                 { Nothing }
748

749 750 751 752 753
-----------------------------------------------------------------------------
-- Stand-alone deriving

-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
754
        : 'deriving' 'instance' inst_type { LL (DerivDecl $3) }
755

756 757 758
-----------------------------------------------------------------------------
-- Nested declarations

759
-- Declaration in class bodies
760
--
761
decl_cls  :: { Located (OrdList (LHsDecl RdrName)) }
762
decl_cls  : at_decl_cls                 { LL (unitOL $1) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
763
          | decl                        { $1 }
764

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
765
          -- A 'default' signature used with the generic-programming extension
766 767 768 769
          | 'default' infixexp '::' sigtypedoc
                    {% do { (TypeSig l ty) <- checkValSig $2 $4
                          ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } }

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
770 771 772 773 774
decls_cls :: { Located (OrdList (LHsDecl RdrName)) }    -- Reversed
          : decls_cls ';' decl_cls      { LL (unLoc $1 `appOL` unLoc $3) }
          | decls_cls ';'               { LL (unLoc $1) }
          | decl_cls                    { $1 }
          | {- empty -}                 { noLoc nilOL }
775 776


777
decllist_cls
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
778 779 780
        :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
        : '{'         decls_cls '}'     { LL (unLoc $2) }
        |     vocurly decls_cls close   { $2 }
781

782
-- Class body
783
--
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
784 785 786 787 788
where_cls :: { Located (OrdList (LHsDecl RdrName)) }    -- Reversed
                                -- No implicit parameters
                                -- May have type declarations
        : 'where' decllist_cls          { LL (unLoc $2) }
        | {- empty -}                   { noLoc nilOL }
789 790 791 792

-- Declarations in instance bodies
--
decl_inst  :: { Located (OrdList (LHsDecl RdrName)) }
793
decl_inst  : at_decl_inst               { LL (unitOL (L1 (InstD (FamInstD (unLoc $1))))) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
794
           | decl                       { $1 }
795

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
796 797 798 799 800
decls_inst :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
           : decls_inst ';' decl_inst   { LL (unLoc $1 `appOL` unLoc $3) }
           | decls_inst ';'             { LL (unLoc $1) }
           | decl_inst                  { $1 }
           | {- empty -}                { noLoc nilOL }
801 802

decllist_inst 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
803 804 805
        :: { Located (OrdList (LHsDecl RdrName)) }      -- Reversed
        : '{'         decls_inst '}'    { LL (unLoc $2) }
        |     vocurly decls_inst close  { $2 }
806 807 808

-- Instance body
--
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
809 810 811 812 813
where_inst :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
                                -- No implicit parameters
                                -- May have type declarations
        : 'where' decllist_inst         { LL (unLoc $2) }
        | {- empty -}                   { noLoc nilOL }
814

815 816
-- Declarations in binding groups other than classes and instances
--
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
817 818
decls   :: { Located (OrdList (LHsDecl RdrName)) }      
        : decls ';' decl                { let { this = unLoc $3;
Ian Lynagh's avatar
Ian Lynagh committed
819
                                    rest = unLoc $1;
Ian Lynagh's avatar
Ian Lynagh committed
820
                                    these = rest `appOL` this }
Ian Lynagh's avatar
Ian Lynagh committed
821 822
                              in rest `seq` this `seq` these `seq`
                                    LL these }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
823 824 825
        | decls ';'                     { LL (unLoc $1) }
        | decl                          { $1 }
        | {- empty -}                   { noLoc nilOL }
826

827
decllist :: { Located (OrdList (LHsDecl RdrName)) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
828 829
        : '{'            decls '}'      { LL (unLoc $2) }
        |     vocurly    decls close    { $2 }
830

831 832
-- Binding groups other than those of class and instance declarations
--
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
833 834 835 836 837
binds   ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters
                                                -- No type declarations
        : decllist                      { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
        | '{'            dbinds '}'     { LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
        |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
838

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
839 840 841 842
wherebinds :: { Located (HsLocalBinds RdrName) }        -- May have implicit parameters
                                                -- No type declarations
        : 'where' binds                 { LL (unLoc $2) }
        | {- empty -}                   { noLoc emptyLocalBinds }
843 844 845 846 847


-----------------------------------------------------------------------------
-- Transformation Rules

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
848 849 850 851 852
rules   :: { OrdList (LHsDecl RdrName) }
        :  rules ';' rule                       { $1 `snocOL` $3 }
        |  rules ';'                            { $1 }
        |  rule                                 { unitOL $1 }
        |  {- empty -}                          { nilOL }
853

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
854 855 856 857 858
rule    :: { LHsDecl RdrName }
        : STRING activation rule_forall infixexp '=' exp
             { LL $ RuleD (HsRule (getSTRING $1) 
                                  ($2 `orElse` AlwaysActive) 
                                  $3 $4 placeHolderNames $6 placeHolderNames) }
859

860 861 862
activation :: { Maybe Activation } 
        : {- empty -}                           { Nothing }
        | explicit_activation                   { Just $1 }
863 864

explicit_activation :: { Activation }  -- In brackets
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
865 866
        : '[' INTEGER ']'               { ActiveAfter  (fromInteger (getINTEGER $2)) }
        | '[' '~' INTEGER ']'           { ActiveBefore (fromInteger (getINTEGER $3)) }
867 868

rule_forall :: { [RuleBndr RdrName] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
869 870
        : 'forall' rule_var_list '.'            { $2 }
        | {- empty -}                           { [] }
871 872

rule_var_list :: { [RuleBndr RdrName] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
873 874
        : rule_var                              { [$1] }
        | rule_var rule_var_list                { $1 : $2 }
875 876

rule_var :: { RuleBndr RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
877
        : varid                                 { RuleBndr $1 }
878
        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (HsBSig $4 placeHolderBndrs) }
879 880

-----------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
881 882 883
-- Warnings and deprecations (c.f. rules)

warnings :: { OrdList (LHsDecl RdrName) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
884 885 886 887
        : warnings ';' warning          { $1 `appOL` $3 }
        | warnings ';'                  { $1 }
        | warning                               { $1 }
        | {- empty -}                           { nilOL }
Ian Lynagh's avatar
Ian Lynagh committed
888 889 890

-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LHsDecl RdrName) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
891 892 893
        : namelist strings
                { toOL [ LL $ WarningD (Warning n (WarningTxt $ unLoc $2))
                       | n <- unLoc $1 ] }
894

895
deprecations :: { OrdList (LHsDecl RdrName) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
896 897 898 899
        : deprecations ';' deprecation          { $1 `appOL` $3 }
        | deprecations ';'                      { $1 }
        | deprecation                           { $1 }
        | {- empty -}                           { nilOL }
900 901

-- SUP: TEMPORARY HACK, not checking for `module Foo'
902
deprecation :: { OrdList (LHsDecl RdrName) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
903 904 905
        : namelist strings
                { toOL [ LL $ WarningD (Warning n (DeprecatedTxt $ unLoc $2))
                       | n <- unLoc $1 ] }
906

907 908 909 910 911 912 913 914
strings :: { Located [FastString] }
    : STRING { L1 [getSTRING $1] }
    | '[' stringlist ']' { LL $ fromOL (unLoc $2) }

stringlist :: { Located (OrdList FastString) }
    : stringlist ',' STRING { LL (unLoc $1 `snocOL` getSTRING $3) }
    | STRING                { LL (unitOL (getSTRING $1)) }

915 916 917 918 919 920 921
-----------------------------------------------------------------------------
-- Annotations
annotation :: { LHsDecl RdrName }
    : '{-# ANN' name_var aexp '#-}'      { LL (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) }
    | '{-# ANN' 'type' tycon aexp '#-}'  { LL (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) }
    | '{-# ANN' 'module' aexp '#-}'      { LL (AnnD $ HsAnnotation ModuleAnnProvenance $3) }

922 923 924 925 926

-----------------------------------------------------------------------------
-- Foreign import and export declarations

fdecl :: { LHsDecl RdrName }
Simon Marlow's avatar
Simon Marlow committed
927
fdecl : 'import' callconv safety fspec
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
928 929 930 931
                {% mkImport $2 $3 (unLoc $4) >>= return.LL }
      | 'import' callconv        fspec          
                {% do { d <- mkImport $2 PlaySafe (unLoc $3);
                        return (LL d) } }
932
      | 'export' callconv fspec
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
933
                {% mkExport $2 (unLoc $3) >>= return.LL }
934

935
callconv :: { CCallConv }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
936 937
          : 'stdcall'                   { StdCallConv }
          | 'ccall'                     { CCallConv   }
938
          | 'capi'                      { CApiConv    }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
939
          | 'prim'                      { PrimCallConv}
940 941

safety :: { Safety }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
942 943 944
        : 'unsafe'                      { PlayRisky }
        | 'safe'                        { PlaySafe }
        | 'interruptible'               { PlayInterruptible }
945 946

fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
947 948
       : STRING var '::' sigtypedoc     { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
       |        var '::' sigtypedoc     { LL (noLoc nilFS, $1, $3) }
949 950 951 952 953 954 955 956
         -- if the entity string is missing, it defaults to the empty string;
         -- the meaning of an empty entity string depends on the calling
         -- convention

-----------------------------------------------------------------------------
-- Type signatures

opt_sig :: { Maybe (LHsType RdrName) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
957 958
        : {- empty -}                   { Nothing }
        | '::' sigtype                  { Just $2 }
959 960

opt_asig :: { Maybe (LHsType RdrName) }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
961 962
        : {- empty -}                   { Nothing }
        | '::' atype                    { Just $2 }
963

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
964
sigtype :: { LHsType RdrName }          -- Always a HsForAllTy,
965
                                        -- to tell the renamer where to generalise
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
966 967
        : ctype                         { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
        -- Wrap an Implicit forall if there isn't one there already
968

969
sigtypedoc :: { LHsType RdrName }       -- Always a HsForAllTy
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
970 971
        : ctypedoc                      { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
        -- Wrap an Implicit forall if there isn't one there already
972

973
sig_vars :: { Located [Located RdrName] }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
974 975
         : sig_vars ',' var             { LL ($3 : unLoc $1) }
         | var                          { L1 [$1] }
976

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
977 978 979
sigtypes1 :: { [LHsType RdrName] }      -- Always HsForAllTys
        : sigtype                       { [ $1 ] }
        | sigtype ',' sigtypes1         { $1 : $3 }
980

981 982 983
-----------------------------------------------------------------------------
-- Types

984
infixtype :: { LHsType RdrName }
dreixel's avatar
dreixel committed
985 986
        : btype qtyconop type         { LL $ mkHsOpTy $1 $2 $3 }
        | btype tyvarop  type    { LL $ mkHsOpTy $1 $2 $3 }
987

988
strict_mark :: { Located HsBang }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
989 990
        : '!'                           { L1 HsStrict }
        | '{-# UNPACK' '#-}' '!'        { LL HsUnpack }
991
        | '{-# NOUNPACK' '#-}' '!'      { LL HsNoUnpack }
992

993
-- A ctype is a for-all type
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
994 995 996 997 998 999
ctype   :: { LHsType RdrName }
        : 'forall' tv_bndrs '.' ctype   { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
        | context '=>' ctype            { LL $ mkImplicitHsForAllTy   $1 $3 }
        -- A type of form (context => type) is an *implicit* HsForAllTy
        | ipvar '::' type               { LL (HsIParamTy (unLoc $1) $3) }
        | type                          { $1 }
1000

1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011
----------------------
-- Notes for 'ctypedoc'
-- It would have been nice to simplify the grammar by unifying `ctype` and 
-- ctypedoc` into one production, allowing comments on types everywhere (and
-- rejecting them after parsing, where necessary).  This is however not possible
-- since it leads to ambiguity. The reason is the support for comments on record
-- fields: 
--         data R = R { field :: Int -- ^ comment on the field }
-- If we allow comments on types here, it's not clear if the comment applies
-- to 'field' or to 'Int'. So we must use `ctype` to describe the type.

1012
ctypedoc :: { LHsType RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1013 1014 1015 1016 1017
        : 'forall' tv_bndrs '.' ctypedoc        { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
        | context '=>' ctypedoc         { LL $ mkImplicitHsForAllTy   $1 $3 }
        -- A type of form (context => type) is an *implicit* HsForAllTy
        | ipvar '::' type               { LL (HsIParamTy (unLoc $1) $3) }
        | typedoc                       { $1 }
1018

1019 1020
----------------------
-- Notes for 'context'
1021 1022
-- We parse a context as a btype so that we don't get reduce/reduce
-- errors in ctype.  The basic problem is that
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1023
--      (Eq a, Ord a)
1024
-- looks so much like a tuple type.  We can't tell until we find the =>
1025

waern's avatar
waern committed
1026
-- We have the t1 ~ t2 form both in 'context' and in type, 
1027 1028
-- to permit an individual equational constraint without parenthesis.
-- Thus for some reason we allow    f :: a~b => blah
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1029
-- but not                          f :: ?x::Int => blah
1030
context :: { LHsContext RdrName }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1031 1032 1033
        : btype '~'      btype          {% checkContext
                                             (LL $ HsEqTy $1 $3) }
        | btype                         {% checkContext $1 }
1034

waern's avatar
waern committed
1035
type :: { LHsType RdrName }
1036
        : btype                         { $1 }
dreixel's avatar
dreixel committed
1037 1038
        | btype qtyconop type           { LL $ mkHsOpTy $1 $2 $3 }
        | btype tyvarop  type           { LL $ mkHsOpTy $1 $2 $3 }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
1039 1040
        | btype '->'     ctype          { LL $ HsFunTy $1 $3 }
        | btype '~'      btype          { LL $ HsEqTy $1 $3 }
dreixel's avatar
dreixel committed
1041 1042 1043
                                        -- see Note [Promotion]
        | btype SIMPLEQUOTE qconop type     { LL $ mkHsOpTy $1 $3 $4 }
        | btype SIMPLEQUOTE varop  type     { LL $ mkHsOpTy $1 $3 $4 }
1044

waern's avatar
waern committed
1045
typedoc :: { LHsType RdrName }
1046 1047