Merge branch 'master' into type-nats
[ghc.git] / compiler / parser / Parser.y.pp
index 078cfa4..d45e380 100644 (file)
@@ -41,9 +41,7 @@ import ForeignCall    ( Safety(..), CExportSpec(..), CLabelString,
                        )
 import OccName         ( varName, dataName, tcClsName, tvName )
 import DataCon         ( DataCon, dataConName )
-import SrcLoc          ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
-                         SrcSpan, combineLocs, srcLocFile, 
-                         mkSrcLoc, mkSrcSpan )
+import SrcLoc
 import Module
 import StaticFlags     ( opt_SccProfilingOn, opt_Hpc )
 import Type            ( Kind, liftedTypeKind, unliftedTypeKind )
@@ -216,7 +214,6 @@ incorrect.
  'deriving'    { L _ ITderiving }
  'do'          { L _ ITdo }
  'else'        { L _ ITelse }
- 'generic'     { L _ ITgeneric }
  'hiding'      { L _ IThiding }
  'if'          { L _ ITif }
  'import'      { L _ ITimport }
@@ -255,21 +252,22 @@ incorrect.
  'by'       { L _ ITby }        -- for list transform extension
  'using'    { L _ ITusing }     -- for list transform extension
 
- '{-# INLINE'            { L _ (ITinline_prag _ _) }
- '{-# SPECIALISE'        { L _ ITspec_prag }
+ '{-# INLINE'             { L _ (ITinline_prag _ _) }
+ '{-# SPECIALISE'         { L _ ITspec_prag }
  '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
- '{-# SOURCE'     { L _ ITsource_prag }
- '{-# RULES'      { L _ ITrules_prag }
- '{-# CORE'        { L _ ITcore_prag }              -- hdaume: annotated core
- '{-# SCC'        { L _ ITscc_prag }
- '{-# GENERATED'   { L _ ITgenerated_prag }
- '{-# DEPRECATED'  { L _ ITdeprecated_prag }
- '{-# WARNING'     { L _ ITwarning_prag }
- '{-# UNPACK'      { L _ ITunpack_prag }
- '{-# ANN'         { L _ ITann_prag }
+ '{-# SOURCE'                                  { L _ ITsource_prag }
+ '{-# RULES'                                   { L _ ITrules_prag }
+ '{-# CORE'                                    { L _ ITcore_prag }              -- hdaume: annotated core
+ '{-# SCC'                { L _ ITscc_prag }
+ '{-# GENERATED'          { L _ ITgenerated_prag }
+ '{-# DEPRECATED'         { L _ ITdeprecated_prag }
+ '{-# WARNING'            { L _ ITwarning_prag }
+ '{-# UNPACK'             { L _ ITunpack_prag }
+ '{-# ANN'                { L _ ITann_prag }
  '{-# VECTORISE'          { L _ ITvect_prag }
  '{-# VECTORISE_SCALAR'   { L _ ITvect_scalar_prag }
- '#-}'            { L _ ITclose_prag }
+ '{-# NOVECTORISE'        { L _ ITnovect_prag }
+ '#-}'                                         { L _ ITclose_prag }
 
  '..'          { L _ ITdotdot }                        -- reserved symbols
  ':'           { L _ ITcolon }
@@ -450,8 +448,8 @@ exportlist :: { [LIE RdrName] }
        | exportlist1                           { $1 }
 
 exportlist1 :: { [LIE RdrName] }
-        : expdoclist export expdoclist ',' exportlist  { $1 ++ ($2 : $3) ++ $5 }
-       | expdoclist export expdoclist                 { $1 ++ ($2 : $3) }
+        : expdoclist export expdoclist ',' exportlist  { $1 ++ ($2 ++ $3) ++ $5 }
+       | expdoclist export expdoclist                 { $1 ++ ($2 ++ $3) }
        | expdoclist                                   { $1 }
 
 expdoclist :: { [LIE RdrName] }
@@ -463,15 +461,22 @@ exp_doc :: { LIE RdrName }
         | docnamed      { L1 (IEDocNamed ((fst . unLoc) $1)) } 
         | docnext       { L1 (IEDoc (unLoc $1)) }       
                        
-   -- No longer allow things like [] and (,,,) to be exported
+   -- NOTE 1: No longer allow things like [] and (,,,) to be exported
    -- They are built in syntax, always available
-export         :: { LIE RdrName }
-       :  qvar                         { L1 (IEVar (unLoc $1)) }
-       |  oqtycon                      { L1 (IEThingAbs (unLoc $1)) }
-       |  oqtycon '(' '..' ')'         { LL (IEThingAll (unLoc $1)) }
-       |  oqtycon '(' ')'              { LL (IEThingWith (unLoc $1) []) }
-       |  oqtycon '(' qcnames ')'      { LL (IEThingWith (unLoc $1) (reverse $3)) }
-       |  'module' modid               { LL (IEModuleContents (unLoc $2)) }
+   -- NOTE 2: There is a lot of overlap between value and type names,
+   -- so, in the general case, we parse everything as values,
+   -- and post-process the declaration to determine what is being exported.
+export         :: { [LIE RdrName] }
+       : qcname opt_subordinates { [L (comb3 $1 $1 $2)
+                                       (mkExportSpec (unLoc $1) (unLoc $2))] }
+        | 'type' oqtycons1        { map (fmap IEThingAbs) $2 }
+       | 'module' modid          { [LL (IEModuleContents (unLoc $2))] }
+
+opt_subordinates :: { Located (Maybe Subordinates) }
+        : {- empty -}             { L0 Nothing }
+        | '(' '..' ')'            { LL (Just SubordinateAll) }
+        | '(' ')'                { LL (Just (SubordinateList [])) }
+        | '(' qcnames ')'         { LL (Just (SubordinateList (reverse $2))) }
 
 qcnames :: { [RdrName] }
        :  qcnames ',' qcname_ext       { unLoc $3 : $1 }
@@ -502,13 +507,17 @@ importdecls :: { [LImportDecl RdrName] }
        | {- empty -}                           { [] }
 
 importdecl :: { LImportDecl RdrName }
-       : 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec 
-               { L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) }
+       : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec 
+               { L (comb4 $1 $6 $7 $8) (ImportDecl $6 $5 $2 $3 $4 (unLoc $7) (unLoc $8)) }
 
 maybe_src :: { IsBootInterface }
        : '{-# SOURCE' '#-}'                    { True }
        | {- empty -}                           { False }
 
+maybe_safe :: { Bool }
+       : 'safe'                                { True }
+       | {- empty -}                           { False }
+
 maybe_pkg :: { Maybe FastString }
         : STRING                                { Just (getSTRING $1) }
         | {- empty -}                           { Nothing }
@@ -549,33 +558,34 @@ ops       :: { Located [Located RdrName] }
 -- Top-Level Declarations
 
 topdecls :: { OrdList (LHsDecl RdrName) }
-        : topdecls ';' topdecl                 { $1 `appOL` $3 }
-        | topdecls ';'                         { $1 }
-       | topdecl                               { $1 }
+        : topdecls ';' topdecl                  { $1 `appOL` $3 }
+        | topdecls ';'                          { $1 }
+        | topdecl                               { $1 }
 
 topdecl :: { OrdList (LHsDecl RdrName) }
-       : cl_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
-       | ty_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
-       | 'instance' inst_type where_inst
-           { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
-             in 
-             unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
+        : cl_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
+        | ty_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
+        | 'instance' inst_type where_inst
+            { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+              in 
+              unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
         | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
-       | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
-       | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
+        | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
+        | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
         | '{-# DEPRECATED' deprecations '#-}'   { $2 }
         | '{-# WARNING' warnings '#-}'          { $2 }
-       | '{-# RULES' rules '#-}'               { $2 }
-       | '{-# VECTORISE_SCALAR' qvar '#-}'     { unitOL $ LL $ VectD (HsVect $2 Nothing) }
-       | '{-# VECTORISE' qvar '=' exp '#-}'    { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }
-       | 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) } 
+        | '{-# RULES' rules '#-}'               { $2 }
+        | '{-# 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) }
+        | 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) } 
 
 -- Type classes
 --
@@ -722,6 +732,11 @@ decl_cls  :: { Located (OrdList (LHsDecl RdrName)) }
 decl_cls  : at_decl_cls                        { LL (unitOL (L1 (TyClD (unLoc $1)))) }
          | decl                        { $1 }
 
+         -- A 'default' signature used with the generic-programming extension
+          | 'default' infixexp '::' sigtypedoc
+                    {% do { (TypeSig l ty) <- checkValSig $2 $4
+                          ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } }
+
 decls_cls :: { Located (OrdList (LHsDecl RdrName)) }   -- Reversed
          : decls_cls ';' decl_cls      { LL (unLoc $1 `appOL` unLoc $3) }
          | decls_cls ';'               { LL (unLoc $1) }
@@ -1023,8 +1038,7 @@ atype :: { LHsType RdrName }
        | '$(' exp ')'                  { LL $ mkHsSpliceTy $2 }
        | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $ 
                                          mkUnqual varName (getTH_ID_SPLICE $1) }
--- Generics
-        | INTEGER                       { L1 (HsNumTy (getINTEGER $1)) }
+        | INTEGER                       {% mkNumberType (L1 (getINTEGER $1)) }
 
 -- An inst_type is what occurs in the head of an instance decl
 --     e.g.  (Foo a, Gaz b) => Wibble a b
@@ -1080,6 +1094,7 @@ kind      :: { Located Kind }
 akind  :: { Located Kind }
        : '*'                   { L1 liftedTypeKind }
        | '!'                   { L1 unliftedTypeKind }
+       | tycon                 {% checkKindCon $1 }
        | '(' kind ')'          { LL (unLoc $2) }
 
 
@@ -1233,15 +1248,13 @@ gdrh :: { LGRHS RdrName }
        : '|' guardquals '=' exp        { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
 
 sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
-        : 'generic' infixexp '::' sigtypedoc
-                        {% do (TypeSig l ty) <- checkValSig $2 $4
-                        ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) }
+        : 
        -- See Note [Declaration/signature overlap] for why we need infixexp here
-       | infixexp '::' sigtypedoc
+         infixexp '::' sigtypedoc
                         {% do s <- checkValSig $1 $3 
                         ; return (LL $ unitOL (LL $ SigD s)) }
        | var ',' sig_vars '::' sigtypedoc
-                               { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
+                               { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] }
        | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                             | n <- unLoc $3 ] }
        | '{-# INLINE'   activation qvar '#-}'        
@@ -1262,7 +1275,7 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
        : TH_QUASIQUOTE   { let { loc = getLoc $1
                                 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
                                 ; quoterId = mkUnqual varName quoter }
-                            in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
+                            in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
 exp   :: { LHsExpr RdrName }
        : infixexp '::' sigtype         { LL $ ExprWithTySig $1 $3 }
@@ -1288,14 +1301,9 @@ exp10 :: { LHsExpr RdrName }
        | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
        | '-' fexp                              { LL $ NegApp $2 noSyntaxExpr }
 
-       | 'do' stmtlist                 {% let loc = comb2 $1 $2 in
-                                          checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
-                                          return (L loc (mkHsDo DoExpr stmts body)) }
-       | 'mdo' stmtlist                {% let loc = comb2 $1 $2 in
-                                          checkDo loc (unLoc $2)  >>= \ (stmts,body) ->
-                                           return (L loc (mkHsDo MDoExpr
-                                                                 [L loc (mkRecStmt stmts)]
-                                                                 body)) }
+       | 'do' stmtlist                 { L (comb2 $1 $2) (mkHsDo DoExpr  (unLoc $2)) }
+       | 'mdo' stmtlist                { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
+
         | scc_annot exp                                { LL $ if opt_SccProfilingOn
                                                        then HsSCC (unLoc $1) $2
                                                        else HsPar $2 }
@@ -1470,7 +1478,10 @@ list :: { LHsExpr RdrName }
        | texp ',' exp '..'     { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
        | texp '..' exp         { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
        | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-       | texp '|' flattenedpquals      { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
+       | texp '|' flattenedpquals      
+             {% checkMonadComp >>= \ ctxt ->
+               return (sL (comb2 $1 $>) $ 
+                        mkHsComp ctxt (unLoc $3) $1) }
 
 lexps :: { Located [LHsExpr RdrName] }
        : lexps ',' texp                { LL (((:) $! $3) $! unLoc $1) }
@@ -1485,7 +1496,7 @@ flattenedpquals :: { Located [LStmt RdrName] }
                     -- We just had one thing in our "parallel" list so 
                     -- we simply return that thing directly
                     
-                    qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]]
+                    qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr]
                     -- We actually found some actual parallel lists so
                     -- we wrap them into as a ParStmt
                 }
@@ -1506,8 +1517,7 @@ squals :: { Located [LStmt RdrName] }     -- In reverse order, because the last
 
 -- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
 -- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user
--- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile
--- a program that makes use of this temporary syntax you must supply that flag to GHC
+-- demand.
 
 transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
                        -- Function is applied to a list of stmts *in order*
@@ -1542,7 +1552,7 @@ parr :: { LHsExpr RdrName }
                                                       (reverse (unLoc $1)) }
        | texp '..' exp                 { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
        | texp ',' exp '..' exp         { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
-       | texp '|' flattenedpquals      { LL $ mkHsDo PArrComp (unLoc $3) $1 }
+       | texp '|' flattenedpquals      { LL $ mkHsComp PArrComp (unLoc $3) $1 }
 
 -- We are reusing `lexps' and `flattenedpquals' from the list case.
 
@@ -1731,6 +1741,10 @@ gtycon   :: { Located RdrName }  -- A "general" qualified tycon
        | '[' ']'                       { LL $ listTyCon_RDR }
        | '[:' ':]'                     { LL $ parrTyCon_RDR }
 
+oqtycons1 :: { [Located RdrName] }
+        : oqtycon                       { [$1] }
+        | oqtycons1 oqtycon             { $2 : $1 }
+
 oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon
        : qtycon                        { $1 }
        | '(' qtyconsym ')'             { LL (unLoc $2) }
@@ -1753,6 +1767,15 @@ qtyconsym :: { Located RdrName }
 
 tyconsym :: { Located RdrName }
        : CONSYM                        { L1 $! mkUnqual tcClsName (getCONSYM $1) }
+        -- Does not include "!", because that is used for strictness marks
+        -- or ".", because that separates the quantified type vars from the rest
+        -- or "*", because that's used for kinds  (XXX: Add this)
+        | VARSYM                       { L1 $! mkUnqual tcClsName (getVARSYM $1) }
+        | '*'                           { L1 $! mkUnqual tcClsName (fsLit "*") }
+    
+
+
+
 
 -----------------------------------------------------------------------------
 -- Operators
@@ -1786,11 +1809,9 @@ qvaropm :: { Located RdrName }
 
 tyvar   :: { Located RdrName }
 tyvar   : tyvarid              { $1 }
-       | '(' tyvarsym ')'      { LL (unLoc $2) }
 
 tyvarop :: { Located RdrName }
 tyvarop : '`' tyvarid '`'      { LL (unLoc $2) }
-       | tyvarsym              { $1 }
        | '.'                   {% parseErrorSDoc (getLoc $1) 
                                      (vcat [ptext (sLit "Illegal symbol '.' in type"), 
                                             ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"),
@@ -1805,12 +1826,6 @@ tyvarid  :: { Located RdrName }
        | 'interruptible'       { L1 $! mkUnqual tvName (fsLit "interruptible") }
        | 'threadsafe'          { L1 $! mkUnqual tvName (fsLit "threadsafe") }
 
-tyvarsym :: { Located RdrName }
--- Does not include "!", because that is used for strictness marks
---              or ".", because that separates the quantified type vars from the rest
---              or "*", because that's used for kinds
-tyvarsym : VARSYM              { L1 $! mkUnqual tvName (getVARSYM $1) }
-
 -----------------------------------------------------------------------------
 -- Variables