-- ---------------------------------------------------------------------------
{
-{-# OPTIONS -Wwarn -w #-}
+{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
+-- The NoMonomorphismRestriction deals with a Happy infelicity
+-- With OutsideIn's more conservativ monomorphism restriction
+-- we aren't generalising
+-- notHappyAtAll = error "urk"
+-- which is terrible. Switching off the restriction allows
+-- the generalisation. Better would be to make Happy generate
+-- an appropriate signature.
+
-- 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
mkSrcLoc, mkSrcSpan )
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
-import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
+import Type ( Kind, liftedTypeKind, unliftedTypeKind )
+import Coercion ( mkArrowKind )
import Class ( FunDep )
-import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- Activation(..), RuleMatchInfo(..), defaultInlineSpec )
+import BasicTypes
import DynFlags
import OrdList
-import HaddockParse
-import {-# SOURCE #-} HaddockLex hiding ( Token )
import HaddockUtils
import FastString
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
'prim' { L _ ITprimcallconv }
- 'dotnet' { L _ ITdotnet }
'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension
'group' { L _ ITgroup } -- for list transform extension
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
- '{-# INLINE' { L _ (ITinline_prag _) }
- '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_prag _) }
+ '{-# INLINE' { L _ (ITinline_prag _ _) }
'{-# SPECIALISE' { L _ ITspec_prag }
'{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) }
'{-# SOURCE' { L _ ITsource_prag }
'{-# SCC' { L _ ITscc_prag }
'{-# GENERATED' { L _ ITgenerated_prag }
'{-# DEPRECATED' { L _ ITdeprecated_prag }
- '{-# WARNING' { L _ ITwarning_prag }
+ '{-# WARNING' { L _ ITwarning_prag }
'{-# UNPACK' { L _ ITunpack_prag }
- '{-# ANN' { L _ ITann_prag }
+ '{-# ANN' { L _ ITann_prag }
'#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
module :: { Located (HsModule RdrName) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
- {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
- return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
- info doc) )}}
+ {% fileSrcSpan >>= \ loc ->
+ return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 $1
+ ) )}
| body2
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule Nothing Nothing
- (fst $1) (snd $1) Nothing emptyHaddockModInfo
- Nothing)) }
+ (fst $1) (snd $1) Nothing Nothing
+ )) }
-maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
+maybedocheader :: { Maybe LHsDocString }
: moduleheader { $1 }
- | {- empty -} { (emptyHaddockModInfo, Nothing) }
+ | {- empty -} { Nothing }
missing_module_keyword :: { () }
: {- empty -} {% pushCurrentContext }
maybemodwarning :: { Maybe WarningTxt }
- : '{-# DEPRECATED' STRING '#-}' { Just (DeprecatedTxt (getSTRING $2)) }
- | '{-# WARNING' STRING '#-}' { Just (WarningTxt (getSTRING $2)) }
+ : '{-# DEPRECATED' strings '#-}' { Just (DeprecatedTxt $ unLoc $2) }
+ | '{-# WARNING' strings '#-}' { Just (WarningTxt $ unLoc $2) }
| {- empty -} { Nothing }
body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
header :: { Located (HsModule RdrName) }
: maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
- {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
- return (L loc (HsModule (Just $3) $5 $7 [] $4
- info doc))}}
+ {% fileSrcSpan >>= \ loc ->
+ return (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ))}
| missing_module_keyword importdecls
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule Nothing Nothing $2 [] Nothing
- emptyHaddockModInfo Nothing)) }
+ Nothing)) }
header_body :: { [LImportDecl RdrName] }
: '{' importdecls { $2 }
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) }
- | '{-# DEPRECATED' deprecations '#-}' { $2 }
- | '{-# WARNING' warnings '#-}' { $2 }
+ | '{-# DEPRECATED' deprecations '#-}' { $2 }
+ | '{-# WARNING' warnings '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
| annotation { unitOL $1 }
| decl { unLoc $1 }
-- Template Haskell Extension
- | '$(' exp ')' { unitOL (LL $ SpliceD (SpliceDecl $2)) }
- | TH_ID_SPLICE { unitOL (LL $ SpliceD (SpliceDecl $
- L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
- )) }
+ -- 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
--
-- ordinary GADT declaration
| data_or_newtype tycl_hdr opt_kind_sig
- 'where' gadt_constrlist
+ gadt_constrlist
deriving
{% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2
- (unLoc $3) (reverse (unLoc $5)) (unLoc $6) }
+ (unLoc $3) (unLoc $4) (unLoc $5) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
- 'where' gadt_constrlist
+ gadt_constrlist
deriving
- {% mkTyData (comb4 $1 $3 $6 $7) (unLoc $1) True $3
- (unLoc $4) (reverse (unLoc $6)) (unLoc $7) }
+ {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
+ (unLoc $4) (unLoc $5) (unLoc $6) }
-- Associated type family declarations
--
-- GADT instance declaration
| data_or_newtype tycl_hdr opt_kind_sig
- 'where' gadt_constrlist
+ gadt_constrlist
deriving
- {% mkTyData (comb4 $1 $2 $5 $6) (unLoc $1) True $2
- (unLoc $3) (reverse (unLoc $5)) (unLoc $6) }
+ {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) True $2
+ (unLoc $3) (unLoc $4) (unLoc $5) }
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
-- (Eq a, Ord b) => T a b
-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
-tycl_hdr :: { Located (LHsContext RdrName, LHsType RdrName) }
- : context '=>' type { LL ($1, $3) }
- | type { L1 (noLoc [], $1) }
+tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
+ : context '=>' type { LL (Just $1, $3) }
+ | type { L1 (Nothing, $1) }
-----------------------------------------------------------------------------
-- Stand-alone deriving
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
- : 'deriving' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) }
+ : 'deriving' 'instance' inst_type { LL (DerivDecl $3) }
-----------------------------------------------------------------------------
-- Nested declarations
binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
-- No type declarations
: decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
- | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
- | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
+ | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
+ | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
-- No type declarations
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LHsDecl RdrName) }
- : namelist STRING
- { toOL [ LL $ WarningD (Warning n (WarningTxt (getSTRING $2)))
+ : namelist strings
+ { toOL [ LL $ WarningD (Warning n (WarningTxt $ unLoc $2))
| n <- unLoc $1 ] }
deprecations :: { OrdList (LHsDecl RdrName) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { OrdList (LHsDecl RdrName) }
- : namelist STRING
- { toOL [ LL $ WarningD (Warning n (DeprecatedTxt (getSTRING $2)))
+ : namelist strings
+ { toOL [ LL $ WarningD (Warning n (DeprecatedTxt $ unLoc $2))
| n <- unLoc $1 ] }
+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)) }
+
-----------------------------------------------------------------------------
-- Annotations
annotation :: { LHsDecl RdrName }
| 'export' callconv fspec
{% mkExport $2 (unLoc $3) >>= return.LL }
-callconv :: { CallConv }
- : 'stdcall' { CCall StdCallConv }
- | 'ccall' { CCall CCallConv }
- | 'prim' { CCall PrimCallConv}
- | 'dotnet' { DNCall }
+callconv :: { CCallConv }
+ : 'stdcall' { StdCallConv }
+ | 'ccall' { CCallConv }
+ | 'prim' { PrimCallConv}
safety :: { Safety }
: 'unsafe' { PlayRisky }
strict_mark :: { Located HsBang }
: '!' { L1 HsStrict }
- | '{-# UNPACK' '#-}' '!' { LL HsUnbox }
+ | '{-# UNPACK' '#-}' '!' { LL HsUnpack }
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
type :: { LHsType RdrName }
: btype { $1 }
- | btype qtyconop type { LL $ HsOpTy $1 $2 $3 }
+ | btype qtyconop type { LL $ HsOpTy $1 $2 $3 }
| btype tyvarop type { LL $ HsOpTy $1 $2 $3 }
| btype '->' ctype { LL $ HsFunTy $1 $3 }
| btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) }
| '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) }
- | '$(' exp ')' { LL $ HsSpliceTy (mkHsSplice $2 ) }
- | TH_ID_SPLICE { LL $ HsSpliceTy (mkHsSplice
- (L1 $ HsVar (mkUnqual varName
- (getTH_ID_SPLICE $1)))) } -- $x
+ | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) }
+ | '$(' exp ')' { LL $ mkHsSpliceTy $2 }
+ | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
+ mkUnqual varName (getTH_ID_SPLICE $1) }
-- Generics
| INTEGER { L1 (HsNumTy (getINTEGER $1)) }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
- : tyvar { L1 (UserTyVar (unLoc $1)) }
+ : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2)
(unLoc $4)) }
-----------------------------------------------------------------------------
-- Datatype declarations
-gadt_constrlist :: { Located [LConDecl RdrName] }
- : '{' gadt_constrs '}' { LL (unLoc $2) }
- | vocurly gadt_constrs close { $2 }
+gadt_constrlist :: { Located [LConDecl RdrName] } -- Returned in order
+ : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) (unLoc $3) }
+ | 'where' vocurly gadt_constrs close { L (comb2 $1 $3) (unLoc $3) }
+ | {- empty -} { noLoc [] }
gadt_constrs :: { Located [LConDecl RdrName] }
- : gadt_constrs ';' gadt_constr { sL (comb2 $1 (head $3)) ($3 ++ unLoc $1) }
- | gadt_constrs ';' { $1 }
- | gadt_constr { sL (getLoc (head $1)) $1 }
+ : gadt_constr ';' gadt_constrs { L (comb2 (head $1) $3) ($1 ++ unLoc $3) }
+ | gadt_constr { L (getLoc (head $1)) $1 }
+ | {- empty -} { noLoc [] }
-- We allow the following forms:
-- C :: Eq a => a -> T a
-- D { x,y :: a } :: T a
-- forall a. Eq a => D { x,y :: a } :: T a
-gadt_constr :: { [LConDecl RdrName] }
+gadt_constr :: { [LConDecl RdrName] } -- Returns a list because of: C,D :: ty
: con_list '::' sigtype
{ map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) }
; return [cd] } }
constrs :: { Located [LConDecl RdrName] }
- : {- empty; a GHC extension -} { noLoc [] }
- | maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
+ : maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
constrs1 :: { Located [LConDecl RdrName] }
: constrs1 maybe_docnext '|' maybe_docprev constr { LL (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4) }
-----------------------------------------------------------------------------
-- Value definitions
-{- There's an awkward overlap with a type signature. Consider
+{- Note [Declaration/signature overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There's an awkward overlap with a type signature. Consider
f :: Int -> Int = ...rhs...
Then we can't tell whether it's a type signature or a value
definition with a result signature until we see the '='.
docdecl :: { LHsDecl RdrName }
: docdecld { L1 (DocD (unLoc $1)) }
-docdecld :: { LDocDecl RdrName }
+docdecld :: { LDocDecl }
: docnext { L1 (DocCommentNext (unLoc $1)) }
| docprev { L1 (DocCommentPrev (unLoc $1)) }
| docnamed { L1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }
: '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
- : infixexp '::' sigtypedoc
- {% do s <- checkValSig $1 $3;
- return (LL $ unitOL (LL $ SigD s)) }
- -- See the above notes for why we need infixexp here
+ : infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3
+ ; return (LL $ unitOL (LL $ SigD s)) }
+ -- See Note [Declaration/signature overlap] for why we need infixexp here
| var ',' sig_vars '::' sigtypedoc
{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
| infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| n <- unLoc $3 ] }
| '{-# INLINE' activation qvar '#-}'
- { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) }
- | '{-# INLINE_CONLIKE' activation qvar '#-}'
- { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) }
+ { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
+ { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma)
| t <- $4] }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1)))
+ { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
| t <- $5] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
- { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
+ { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
-----------------------------------------------------------------------------
-- Expressions
+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) }
+
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
| infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
(unguardedGRHSs $6)
]) }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
- | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 }
+ | 'if' exp optSemi 'then' exp optSemi 'else' exp
+ {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
+ return (LL $ HsIf $2 $5 $8) }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ NegApp $2 noSyntaxExpr }
-- hdaume: core annotation
| fexp { $1 }
+optSemi :: { Bool }
+ : ';' { True }
+ | {- empty -} { False }
+
scc_annot :: { Located FastString }
: '_scc_' STRING {% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
( do scc <- getSCC $2; return $ LL scc ) }
-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRING $1) placeHolderType) }
| INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGER $1) placeHolderType) }
| RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) }
+
-- N.B.: sections get parsed by these next two productions.
-- This allows you to write, e.g., '(+ 3, 4 -)', which isn't correct Haskell98
-- (you'd have to write '((+ 3), (4 -))')
-- but the less cluttered version fell out of having texps.
| '(' texp ')' { LL (HsPar $2) }
- | '(' texp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
- | '(#' texps '#)' { LL $ ExplicitTuple (reverse $2) Unboxed }
+ | '(' tup_exprs ')' { LL (ExplicitTuple $2 Boxed) }
+
+ | '(#' texp '#)' { LL (ExplicitTuple [Present $2] Unboxed) }
+ | '(#' tup_exprs '#)' { LL (ExplicitTuple $2 Unboxed) }
+
| '[' list ']' { LL (unLoc $2) }
| '[:' parr ':]' { LL (unLoc $2) }
| '_' { L1 EWildPat }
-- Template Haskell Extension
| TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice
(L1 $ HsVar (mkUnqual varName
- (getTH_ID_SPLICE $1)))) } -- $x
- | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp )
-
- | TH_QUASIQUOTE { let { loc = getLoc $1
- ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
- ; quoterId = mkUnqual varName quoter
- }
- in sL loc $ HsQuasiQuoteE (mkHsQuasiQuote quoterId quoteSpan quote) }
+ (getTH_ID_SPLICE $1)))) }
+ | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) }
+
+
| TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) }
| '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) }
| '[p|' infixexp '|]' {% checkPattern $2 >>= \p ->
return (LL $ HsBracket (PatBr p)) }
- | '[d|' cvtopbody '|]' {% checkDecBrGroup $2 >>= \g ->
- return (LL $ HsBracket (DecBr g)) }
+ | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBrL $2) }
+ | quasiquote { L1 (HsQuasiQuoteE (unLoc $1)) }
-- arrow notation extension
| '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) }
: {- empty -} { [] }
| cvtopdecls { $1 }
+-----------------------------------------------------------------------------
+-- Tuple expressions
+
-- "texp" is short for tuple expressions:
-- things that can appear unparenthesized as long as they're
-- inside parens or delimitted by commas
| qopm infixexp { LL $ SectionR $1 $2 }
-- View patterns get parenthesized above
- | exp '->' exp { LL $ EViewPat $1 $3 }
+ | exp '->' texp { LL $ EViewPat $1 $3 }
-texps :: { [LHsExpr RdrName] }
- : texps ',' texp { $3 : $1 }
- | texp { [$1] }
+-- Always at least one comma
+tup_exprs :: { [HsTupArg RdrName] }
+ : texp commas_tup_tail { Present $1 : $2 }
+ | commas tup_tail { replicate $1 missingTupArg ++ $2 }
+-- Always starts with commas; always follows an expr
+commas_tup_tail :: { [HsTupArg RdrName] }
+commas_tup_tail : commas tup_tail { replicate ($1-1) missingTupArg ++ $2 }
+
+-- Always follows a comma
+tup_tail :: { [HsTupArg RdrName] }
+ : texp commas_tup_tail { Present $1 : $2 }
+ | texp { [Present $1] }
+ | {- empty -} { [missingTupArg] }
-----------------------------------------------------------------------------
-- List expressions
flattenedpquals :: { Located [LStmt RdrName] }
: pquals { case (unLoc $1) of
- ParStmt [(qs, _)] -> L1 qs
+ [qs] -> L1 qs
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
- _ -> L1 [$1]
+ qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]]
-- We actually found some actual parallel lists so
- -- we leave them into as a ParStmt
+ -- we wrap them into as a ParStmt
}
-pquals :: { LStmt RdrName }
- : pquals1 { L1 (ParStmt [(qs, undefined) | qs <- (reverse (unLoc $1))]) }
-
-pquals1 :: { Located [[LStmt RdrName]] }
- : pquals1 '|' squals { LL (unLoc $3 : unLoc $1) }
- | squals { L (getLoc $1) [unLoc $1] }
-
-squals :: { Located [LStmt RdrName] }
- : squals1 { L (getLoc $1) (reverse (unLoc $1)) }
+pquals :: { Located [[LStmt RdrName]] }
+ : squals '|' pquals { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) }
+ | squals { L (getLoc $1) [reverse (unLoc $1)] }
-squals1 :: { Located [LStmt RdrName] }
- : transformquals1 { LL (unLoc $1) }
-
-transformquals1 :: { Located [LStmt RdrName] }
- : transformquals1 ',' transformqual { LL $ [LL ((unLoc $3) (unLoc $1))] }
- | transformquals1 ',' qual { LL ($3 : unLoc $1) }
--- | transformquals1 ',' '{|' pquals '|}' { LL ($4 : unLoc $1) }
- | transformqual { LL $ [LL ((unLoc $1) [])] }
- | qual { L1 [$1] }
--- | '{|' pquals '|}' { L1 [$2] }
+squals :: { Located [LStmt RdrName] } -- In reverse order, because the last
+ -- one can "grab" the earlier ones
+ : squals ',' transformqual { LL [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] }
+ | squals ',' qual { LL ($3 : unLoc $1) }
+ | transformqual { LL [L (getLoc $1) ((unLoc $1) [])] }
+ | qual { L1 [$1] }
+-- | transformquals1 ',' '{|' pquals '|}' { LL ($4 : unLoc $1) }
+-- | '{|' pquals '|}' { L1 [$2] }
-- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
-- a program that makes use of this temporary syntax you must supply that flag to GHC
transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
- : 'then' exp { LL $ \leftStmts -> (mkTransformStmt (reverse leftStmts) $2) }
- | 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt (reverse leftStmts) $2 $4) }
- | 'then' 'group' 'by' exp { LL $ \leftStmts -> (mkGroupByStmt (reverse leftStmts) $4) }
- | 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt (reverse leftStmts) $4) }
- | 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt (reverse leftStmts) $4 $6) }
+ -- Function is applied to a list of stmts *in order*
+ : 'then' exp { LL $ \leftStmts -> (mkTransformStmt leftStmts $2) }
+ -- >>>
+ | 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt leftStmts $2 $4) }
+ | 'then' 'group' 'by' exp { LL $ \leftStmts -> (mkGroupByStmt leftStmts $4) }
+ -- <<<
+ -- These two productions deliberately have a shift-reduce conflict. I have made 'group' into a special_id,
+ -- which means you can enable TransformListComp while still using Data.List.group. However, this makes the two
+ -- productions ambiguous. I've set things up so that Happy chooses to resolve the conflict in that case by
+ -- choosing the "group by" variant, which is what we want.
+ --
+ -- This is rather dubious: the user might be confused as to how to parse this statement. However, it is a good
+ -- practical choice. NB: Data.List.group :: [a] -> [[a]], so using the first production would not even type check
+ -- if /that/ is the group function we conflict with.
+ | 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt leftStmts $4) }
+ | 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt leftStmts $4 $6) }
-----------------------------------------------------------------------------
-- Parallel array expressions
| '..' { ([], True) }
fbind :: { HsRecField RdrName (LHsExpr RdrName) }
- : qvar '=' exp { HsRecField $1 $3 False }
- | qvar { HsRecField $1 (L (getLoc $1) (HsVar (unLoc $1))) True }
- -- Here's where we say that plain 'x'
- -- means exactly 'x = x'. The pun-flag boolean is
- -- there so we can still print it right
+ : qvar '=' exp { HsRecField $1 $3 False }
+ | qvar { HsRecField $1 placeHolderPunRhs True }
+ -- In the punning case, use a place-holder
+ -- The renamer fills in the final value
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
sysdcon :: { Located DataCon } -- Wired in data constructors
: '(' ')' { LL unitDataCon }
- | '(' commas ')' { LL $ tupleCon Boxed $2 }
+ | '(' commas ')' { LL $ tupleCon Boxed ($2 + 1) }
| '(#' '#)' { LL $ unboxedSingletonDataCon }
- | '(#' commas '#)' { LL $ tupleCon Unboxed $2 }
+ | '(#' commas '#)' { LL $ tupleCon Unboxed ($2 + 1) }
| '[' ']' { LL nilDataCon }
conop :: { Located RdrName }
gtycon :: { Located RdrName } -- A "general" qualified tycon
: oqtycon { $1 }
| '(' ')' { LL $ getRdrName unitTyCon }
- | '(' commas ')' { LL $ getRdrName (tupleTyCon Boxed $2) }
+ | '(' commas ')' { LL $ getRdrName (tupleTyCon Boxed ($2 + 1)) }
| '(#' '#)' { LL $ getRdrName unboxedSingletonTyCon }
- | '(#' commas '#)' { LL $ getRdrName (tupleTyCon Unboxed $2) }
+ | '(#' commas '#)' { LL $ getRdrName (tupleTyCon Unboxed ($2 + 1)) }
| '(' '->' ')' { LL $ getRdrName funTyCon }
| '[' ']' { LL $ listTyCon_RDR }
| '[:' ':]' { LL $ parrTyCon_RDR }
| 'stdcall' { L1 (fsLit "stdcall") }
| 'ccall' { L1 (fsLit "ccall") }
| 'prim' { L1 (fsLit "prim") }
+ | 'group' { L1 (fsLit "group") }
special_sym :: { Located FastString }
special_sym : '!' { L1 (fsLit "!") }
commas :: { Int }
: commas ',' { $1 + 1 }
- | ',' { 2 }
+ | ',' { 1 }
-----------------------------------------------------------------------------
-- Documentation comments
-docnext :: { LHsDoc RdrName }
- : DOCNEXT {% case parseHaddockParagraphs (tokenise (getDOCNEXT $1)) of {
- MyLeft err -> parseError (getLoc $1) err;
- MyRight doc -> return (L1 doc) } }
+docnext :: { LHsDocString }
+ : DOCNEXT {% return (L1 (HsDocString (mkFastString (getDOCNEXT $1)))) }
-docprev :: { LHsDoc RdrName }
- : DOCPREV {% case parseHaddockParagraphs (tokenise (getDOCPREV $1)) of {
- MyLeft err -> parseError (getLoc $1) err;
- MyRight doc -> return (L1 doc) } }
+docprev :: { LHsDocString }
+ : DOCPREV {% return (L1 (HsDocString (mkFastString (getDOCPREV $1)))) }
-docnamed :: { Located (String, (HsDoc RdrName)) }
+docnamed :: { Located (String, HsDocString) }
: DOCNAMED {%
let string = getDOCNAMED $1
(name, rest) = break isSpace string
- in case parseHaddockParagraphs (tokenise rest) of {
- MyLeft err -> parseError (getLoc $1) err;
- MyRight doc -> return (L1 (name, doc)) } }
+ in return (L1 (name, HsDocString (mkFastString rest))) }
-docsection :: { Located (Int, HsDoc RdrName) }
+docsection :: { Located (Int, HsDocString) }
: DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
- case parseHaddockString (tokenise doc) of {
- MyLeft err -> parseError (getLoc $1) err;
- MyRight doc -> return (L1 (n, doc)) } }
+ return (L1 (n, HsDocString (mkFastString doc))) }
-moduleheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
+moduleheader :: { Maybe LHsDocString }
: DOCNEXT {% let string = getDOCNEXT $1 in
- case parseModuleHeader string of {
- Right (str, info) ->
- case parseHaddockParagraphs (tokenise str) of {
- MyLeft err -> parseError (getLoc $1) err;
- MyRight doc -> return (info, Just doc);
- };
- Left err -> parseError (getLoc $1) err
- } }
-
-maybe_docprev :: { Maybe (LHsDoc RdrName) }
+ return (Just (L1 (HsDocString (mkFastString string)))) }
+
+maybe_docprev :: { Maybe LHsDocString }
: docprev { Just $1 }
| {- empty -} { Nothing }
-maybe_docnext :: { Maybe (LHsDoc RdrName) }
+maybe_docnext :: { Maybe LHsDocString }
: docnext { Just $1 }
| {- empty -} { Nothing }
getPRIMFLOAT (L _ (ITprimfloat x)) = x
getPRIMDOUBLE (L _ (ITprimdouble x)) = x
getTH_ID_SPLICE (L _ (ITidEscape x)) = x
-getINLINE (L _ (ITinline_prag b)) = b
-getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b
-getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b
+getINLINE (L _ (ITinline_prag inl conl)) = (inl,conl)
+getSPEC_INLINE (L _ (ITspec_inline_prag True)) = (Inline, FunLike)
+getSPEC_INLINE (L _ (ITspec_inline_prag False)) = (NoInline,FunLike)
getDOCNEXT (L _ (ITdocCommentNext x)) = x
getDOCPREV (L _ (ITdocCommentPrev x)) = x
fileSrcSpan :: P SrcSpan
fileSrcSpan = do
l <- getSrcLoc;
- let loc = mkSrcLoc (srcLocFile l) 1 0;
+ let loc = mkSrcLoc (srcLocFile l) 1 1;
return (mkSrcSpan loc loc)
}