SrcSpan, combineLocs, srcLocFile,
mkSrcLoc, mkSrcSpan )
import Module
-import StaticFlags ( opt_SccProfilingOn )
+import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
Activation(..), defaultInlineSpec )
import Maybes ( orElse )
import Outputable
-import Control.Monad ( when )
+import Control.Monad ( unless )
import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
{-
-----------------------------------------------------------------------------
+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
+
+-----------------------------------------------------------------------------
+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
+
+-----------------------------------------------------------------------------
6 December 2006
Conflicts: 32 shift/reduce
'data' { L _ ITdata }
'default' { L _ ITdefault }
'deriving' { L _ ITderiving }
+ 'derive' { L _ ITderive }
'do' { L _ ITdo }
'else' { L _ ITelse }
- 'for' { L _ ITfor }
'hiding' { L _ IThiding }
'if' { L _ ITif }
'import' { L _ ITimport }
'threadsafe' { L _ ITthreadsafe }
'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo }
- 'iso' { L _ ITiso }
'family' { L _ ITfamily }
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
'{-# RULES' { L _ ITrules_prag }
'{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
'{-# SCC' { L _ ITscc_prag }
+ '{-# GENERATED' { L _ ITgenerated_prag }
'{-# DEPRECATED' { L _ ITdeprecated_prag }
'{-# UNPACK' { L _ ITunpack_prag }
'#-}' { L _ ITclose_prag }
{% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) ->
return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
opt info doc) )}}
- | missing_module_keyword top close
+ | body2
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule Nothing Nothing
- (fst $2) (snd $2) Nothing Nothing emptyHaddockModInfo
+ (fst $1) (snd $1) Nothing Nothing emptyHaddockModInfo
Nothing)) }
optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
: '{' top '}' { $2 }
| vocurly top close { $2 }
+body2 :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
+ : '{' top '}' { $2 }
+ | missing_module_keyword top close { $2 }
+
top :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
: importdecls { (reverse $1,[]) }
| importdecls ';' cvtopdecls { (reverse $1,$3) }
-- infix type constructors to be declared
{% do { (tc, tvs, _) <- checkSynHdr $2 False
; return (L (comb2 $1 $4)
- (TySynonym tc tvs Nothing $4))
+ (TySynonym tc tvs Nothing $4))
} }
-- type family declarations
-- infix type constructors to be declared
--
{% do { (tc, tvs, _) <- checkSynHdr $3 False
- ; let kind = case unLoc $4 of
- Nothing -> liftedTypeKind
- Just ki -> ki
; return (L (comb3 $1 $3 $4)
- (TyFunction tc tvs False kind))
+ (TyFamily TypeFamily tc tvs (unLoc $4)))
} }
-- type instance declarations
(unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
-- data/newtype family
- | data_or_newtype 'family' tycl_hdr opt_kind_sig
+ | 'data' 'family' tycl_hdr opt_kind_sig
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
- ; checkTyVars tparms -- no type pattern
- ; let kind = case unLoc $4 of
- Nothing -> liftedTypeKind
- Just ki -> ki
+ ; checkTyVars tparms -- no type pattern
+ ; unless (null (unLoc ctxt)) $ -- and no context
+ parseError (getLoc ctxt)
+ "A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $4)
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
- (Just kind) [] Nothing) } }
+ (TyFamily DataFamily tc tvs (unLoc $4)) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
-- infix type constructors to be declared
--
{% do { (tc, tvs, _) <- checkSynHdr $2 False
- ; let kind = case unLoc $3 of
- Nothing -> liftedTypeKind
- Just ki -> ki
; return (L (comb3 $1 $2 $3)
- (TyFunction tc tvs False kind))
+ (TyFamily TypeFamily tc tvs (unLoc $3)))
} }
-- default type instance
} }
-- data/newtype family declaration
- | data_or_newtype tycl_hdr opt_kind_sig
+ | 'data' tycl_hdr opt_kind_sig
{% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
- ; checkTyVars tparms -- no type pattern
- ; let kind = case unLoc $3 of
- Nothing -> liftedTypeKind
- Just ki -> ki
+ ; checkTyVars tparms -- no type pattern
+ ; unless (null (unLoc ctxt)) $ -- and no context
+ parseError (getLoc ctxt)
+ "A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $3)
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
- (Just kind) [] Nothing) } }
+ (TyFamily DataFamily tc tvs (unLoc $3))
+ } }
-- Associate type instances
--
(mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
(unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
-opt_iso :: { Bool }
- : { False }
- | 'iso' { True }
-
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
| 'newtype' { L1 NewType }
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
- : 'deriving' qtycon 'for' qtycon {% do { p <- checkInstType (fmap HsTyVar $2)
- ; checkDerivDecl (LL (DerivDecl p $4)) } }
-
- | 'deriving' '(' inst_type ')' 'for' qtycon {% checkDerivDecl (LL (DerivDecl $3 $6)) }
+ : 'derive' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) }
-----------------------------------------------------------------------------
-- Nested declarations
-- errors in ctype. The basic problem is that
-- (Eq a, Ord a)
-- looks so much like a tuple type. We can't tell until we find the =>
+--
+-- We have the t1 ~ t2 form here and in gentype, to permit an individual
+-- equational constraint without parenthesis.
context :: { LHsContext RdrName }
- : btype {% checkContext $1 }
+ : btype '~' btype {% checkContext
+ (LL $ HsPredTy (HsEqualP $1 $3)) }
+ | btype {% checkContext $1 }
type :: { LHsType RdrName }
: ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
: btype { $1 }
| btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 }
| btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 }
- | btype '->' ctype { LL $ HsFunTy $1 $3 }
+ | btype '->' ctype { LL $ HsFunTy $1 $3 }
+ | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) }
btype :: { LHsType RdrName }
: btype atype { LL $ HsAppTy $1 $2 }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
- | '-' fexp { LL $ mkHsNegApp $2 }
+ | '-' fexp { LL $ NegApp $2 noSyntaxExpr }
| 'do' stmtlist {% let loc = comb2 $1 $2 in
checkDo loc (unLoc $2) >>= \ (stmts,body) ->
| scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2
else HsPar $2 }
+ | hpc_annot exp { LL $ if opt_Hpc
+ then HsTickPragma (unLoc $1) $2
+ else HsPar $2 }
| 'proc' aexp '->' exp
{% checkPattern $2 >>= \ p ->
: '_scc_' STRING { LL $ getSTRING $2 }
| '{-# SCC' STRING '#-}' { LL $ getSTRING $2 }
+hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
+ : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+ { LL $ (getSTRING $2
+ ,( fromInteger $ getINTEGER $3
+ , fromInteger $ getINTEGER $5
+ )
+ ,( fromInteger $ getINTEGER $7
+ , fromInteger $ getINTEGER $9
+ )
+ )
+ }
+
fexp :: { LHsExpr RdrName }
: fexp aexp { LL $ HsApp $1 $2 }
| aexp { $1 }
aexp1 :: { LHsExpr RdrName }
: aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4)
- (reverse $3);
+ $3;
return (LL r) }}
| aexp2 { $1 }
: ipvar { L1 (HsIPVar $! unLoc $1) }
| qcname { L1 (HsVar $! unLoc $1) }
| literal { L1 (HsLit $! unLoc $1) }
+-- This will enable overloaded strings permanently. Normally the renamer turns HsString
+-- into HsOverLit when -foverloaded-strings is on.
+-- | STRING { L1 (HsOverLit $! mkHsIsString (getSTRING $1)) }
| INTEGER { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) }
| RATIONAL { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) }
| '(' exp ')' { LL (HsPar $2) }
| '[|' exp '|]' { LL $ HsBracket (ExpBr $2) }
| '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) }
| '[p|' infixexp '|]' {% checkPattern $2 >>= \p ->
- return (LL $ HsBracket (PatBr p)) }
- | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBr (mkGroup $2)) }
+ return (LL $ HsBracket (PatBr p)) }
+ | '[d|' cvtopbody '|]' {% checkDecBrGroup $2 >>= \g ->
+ return (LL $ HsBracket (DecBr g)) }
-- arrow notation extension
| '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) }
parr :: { LHsExpr RdrName }
: { noLoc (ExplicitPArr placeHolderType []) }
- | exp { L1 $ ExplicitPArr placeHolderType [$1] }
+ | texp { L1 $ ExplicitPArr placeHolderType [$1] }
| lexps { L1 $ ExplicitPArr placeHolderType
(reverse (unLoc $1)) }
- | exp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
- | exp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | exp pquals { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 }
+ | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
+ | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+ | texp pquals { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 }
-- We are reusing `lexps' and `pquals' from the list case.
-- Record Field Update/Construction
fbinds :: { HsRecordBinds RdrName }
- : fbinds1 { $1 }
- | {- empty -} { [] }
+ : fbinds1 { HsRecordBinds (reverse $1) }
+ | {- empty -} { HsRecordBinds [] }
-fbinds1 :: { HsRecordBinds RdrName }
+fbinds1 :: { [(Located id, LHsExpr id)] }
: fbinds1 ',' fbind { $3 : $1 }
| fbind { [$1] }
: VARID { L1 $! mkUnqual varName (getVARID $1) }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'forall' { L1 $! mkUnqual varName FSLIT("forall") }
- | 'iso' { L1 $! mkUnqual varName FSLIT("iso") }
| 'family' { L1 $! mkUnqual varName FSLIT("family") }
qvarsym :: { Located RdrName }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
--- except 'unsafe', 'forall', 'family', and 'iso' whose treatment differs
+-- except 'unsafe', 'forall', and 'family' whose treatment differs
-- depending on context
special_id :: { Located FastString }
special_id
: 'as' { L1 FSLIT("as") }
| 'qualified' { L1 FSLIT("qualified") }
| 'hiding' { L1 FSLIT("hiding") }
- | 'for' { L1 FSLIT("for") }
+ | 'derive' { L1 FSLIT("derive") }
| 'export' { L1 FSLIT("export") }
| 'label' { L1 FSLIT("label") }
| 'dynamic' { L1 FSLIT("dynamic") }
literal :: { Located HsLit }
: CHAR { L1 $ HsChar $ getCHAR $1 }
- | STRING { L1 $ HsString $ getSTRING $1 }
+ | STRING { L1 $ HsString $ getSTRING $1 }
| PRIMINTEGER { L1 $ HsIntPrim $ getPRIMINTEGER $1 }
| PRIMCHAR { L1 $ HsCharPrim $ getPRIMCHAR $1 }
| PRIMSTRING { L1 $ HsStringPrim $ getPRIMSTRING $1 }