summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorYuri de Wit <admin@rodlogic.net>2014-11-07 07:32:26 -0600
committerAustin Seipp <austin@well-typed.com>2014-11-07 07:32:27 -0600
commit37d64a51348a803a1cf974d9e97ec9231215064a (patch)
tree73682cbf7d0c74a38a678b4edd00da0ca88f7974
parent24e05f48f3a3a1130ecd5a46e3089b76ee5a2304 (diff)
downloadhaskell-37d64a51348a803a1cf974d9e97ec9231215064a.tar.gz
small parser/lexer cleanup
Summary: The last three '#define ...' macros were removed from Parser.y.pp and this file was renamed to Parser.y. This basically got rid of a CPP step in the build. Also converted two modules in compiler/parser/ from .lhs to .hs. Test Plan: Does it build? Yes, I performed a full build here and things are looking good. Reviewers: austin Reviewed By: austin Subscribers: adamse, thomie, carter, simonmar Differential Revision: https://phabricator.haskell.org/D411
Diffstat
-rw-r--r--compiler/parser/Ctype.hs (renamed from compiler/parser/Ctype.lhs)25
-rw-r--r--compiler/parser/Lexer.x43
-rw-r--r--compiler/parser/Parser.y (renamed from compiler/parser/Parser.y.pp)898
-rw-r--r--compiler/parser/RdrHsSyn.hs (renamed from compiler/parser/RdrHsSyn.lhs)176
-rw-r--r--ghc.mk13
5 files changed, 577 insertions, 578 deletions
diff --git a/compiler/parser/Ctype.lhs b/compiler/parser/Ctype.hs
index 7233f50e7f..6423218f91 100644
--- a/compiler/parser/Ctype.lhs
+++ b/compiler/parser/Ctype.hs
@@ -1,6 +1,4 @@
-Character classification
-
-\begin{code}
+-- Character classification
{-# LANGUAGE CPP #-}
module Ctype
( is_ident -- Char# -> Bool
@@ -22,11 +20,9 @@ import Data.Int ( Int32 )
import Data.Bits ( Bits((.&.)) )
import Data.Char ( ord, chr )
import Panic
-\end{code}
-Bit masks
+-- Bit masks
-\begin{code}
cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Int
cIdent = 1
cSymbol = 2
@@ -35,12 +31,10 @@ cSpace = 8
cLower = 16
cUpper = 32
cDigit = 64
-\end{code}
-The predicates below look costly, but aren't, GHC+GCC do a great job
-at the big case below.
+-- | The predicates below look costly, but aren't, GHC+GCC do a great job
+-- at the big case below.
-\begin{code}
{-# INLINE is_ctype #-}
is_ctype :: Int -> Char -> Bool
is_ctype mask c = (fromIntegral (charType c) .&. fromIntegral mask) /= (0::Int32)
@@ -55,11 +49,9 @@ is_lower = is_ctype cLower
is_upper = is_ctype cUpper
is_digit = is_ctype cDigit
is_alphanum = is_ctype (cLower+cUpper+cDigit)
-\end{code}
-Utils
+-- Utils
-\begin{code}
hexDigit :: Char -> Int
hexDigit c | is_decdigit c = ord c - ord '0'
| otherwise = ord (to_lower c) - ord 'a' + 10
@@ -87,12 +79,10 @@ to_lower :: Char -> Char
to_lower c
| c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a'))
| otherwise = c
-\end{code}
-We really mean .|. instead of + below, but GHC currently doesn't do
-any constant folding with bitops. *sigh*
+-- | We really mean .|. instead of + below, but GHC currently doesn't do
+-- any constant folding with bitops. *sigh*
-\begin{code}
charType :: Char -> Int
charType c = case c of
'\0' -> 0 -- \000
@@ -224,4 +214,3 @@ charType c = case c of
'\126' -> cAny + cSymbol -- ~
'\127' -> 0 -- \177
_ -> panic ("charType: " ++ show c)
-\end{code}
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index aa5ddc377d..6d05bb9d6d 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -74,33 +74,44 @@ module Lexer (
lexTokenStream
) where
+-- base
+import Control.Applicative
+import Control.Monad
+import Data.Bits
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Ratio
+import Data.Word
+
+-- bytestring
+import Data.ByteString (ByteString)
+
+-- containers
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-- compiler/utils
import Bag
-import ErrUtils
import Outputable
import StringBuffer
import FastString
-import SrcLoc
import UniqFM
+import Util ( readRational )
+
+-- compiler/main
+import ErrUtils
import DynFlags
+
+-- compiler/basicTypes
+import SrcLoc
import Module
-import Ctype
import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
-import Util ( readRational )
-import Control.Applicative
-import Control.Monad
-import Data.Bits
-import Data.ByteString (ByteString)
-import Data.Char
-import Data.List
-import Data.Maybe
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Ratio
-import Data.Word
+-- compiler/parser
+import Ctype
}
-
-- -----------------------------------------------------------------------------
-- Alex "Character set macros"
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y
index e33808daac..2e1b777bb3 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y
@@ -35,39 +35,53 @@ module Parser (parseModule, parseImport, parseStatement,
parseFullStmt, parseStmt, parseIdentifier,
parseType, parseHeader) where
+-- base
+import Control.Monad ( unless, liftM )
+import GHC.Exts
+import Data.Char
+import Control.Monad ( mplus )
+-- compiler/hsSyn
import HsSyn
-import RdrHsSyn
+
+-- compiler/main
import HscTypes ( IsBootInterface, WarningTxt(..) )
-import Lexer
+import DynFlags
+
+-- compiler/utils
+import OrdList
+import BooleanFormula ( BooleanFormula, mkAnd, mkOr, mkTrue, mkVar )
+import FastString
+import Maybes ( orElse )
+import Outputable
+
+-- compiler/basicTypes
import RdrName
-import TcEvidence ( emptyTcEvBinds )
-import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon )
-import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
- unboxedUnitTyCon, unboxedUnitDataCon,
- listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
-import Type ( funTyCon )
-import ForeignCall
import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
import SrcLoc
import Module
+import BasicTypes
+
+-- compiler/types
+import Type ( funTyCon )
import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
import Class ( FunDep )
-import BasicTypes
-import DynFlags
-import OrdList
+
+-- compiler/parser
+import RdrHsSyn
+import Lexer
import HaddockUtils
-import BooleanFormula ( BooleanFormula, mkAnd, mkOr, mkTrue, mkVar )
-import FastString
-import Maybes ( orElse )
-import Outputable
+-- compiler/typecheck
+import TcEvidence ( emptyTcEvBinds )
-import Control.Monad ( unless, liftM )
-import GHC.Exts
-import Data.Char
-import Control.Monad ( mplus )
+-- compiler/prelude
+import ForeignCall
+import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon )
+import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
+ unboxedUnitTyCon, unboxedUnitDataCon,
+ listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
}
{-
@@ -175,24 +189,24 @@ Conflicts: 38 shift/reduce (1.25)
-- ---------------------------------------------------------------------------
-- 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
+This is done using the three functions below, sL0, sL1
+and sLL. Note that these functions were mechanically
+converted from the three macros that used to exist before,
+namely L0, L1 and LL.
They each add a SrcSpan to their argument.
- L0 adds 'noSrcSpan', used for empty productions
+ sL0 adds 'noSrcSpan', used for empty productions
-- This doesn't seem to work anymore -=chak
- L1 for a production with a single token on the lhs. Grabs the SrcSpan
+ sL1 for a production with a single token on the lhs. Grabs the SrcSpan
from that token.
- LL for a production with >1 token on the lhs. Makes up a SrcSpan from
+ sLL 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
+especially careful with empty productions: sLL 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.
@@ -206,14 +220,6 @@ 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 $>)
-
-- -----------------------------------------------------------------------------
-}
@@ -404,7 +410,7 @@ identifier :: { Located RdrName }
| qcon { $1 }
| qvarop { $1 }
| qconop { $1 }
- | '(' '->' ')' { LL $ getRdrName funTyCon }
+ | '(' '->' ')' { sLL $1 $> $ getRdrName funTyCon }
-----------------------------------------------------------------------------
-- Module Header
@@ -497,24 +503,24 @@ expdoclist :: { OrdList (LIE RdrName) }
| {- empty -} { nilOL }
exp_doc :: { OrdList (LIE RdrName) }
- : docsection { unitOL (L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) }
- | docnamed { unitOL (L1 (IEDocNamed ((fst . unLoc) $1))) }
- | docnext { unitOL (L1 (IEDoc (unLoc $1))) }
+ : docsection { unitOL (sL1 $1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) }
+ | docnamed { unitOL (sL1 $1 (IEDocNamed ((fst . unLoc) $1))) }
+ | docnext { unitOL (sL1 $1 (IEDoc (unLoc $1))) }
-- No longer allow things like [] and (,,,) to be exported
-- They are built in syntax, always available
export :: { OrdList (LIE RdrName) }
- : qcname_ext export_subspec { unitOL (LL (mkModuleImpExp (unLoc $1)
+ : qcname_ext export_subspec { unitOL (sLL $1 $> (mkModuleImpExp (unLoc $1)
(unLoc $2))) }
- | 'module' modid { unitOL (LL (IEModuleContents (unLoc $2))) }
- | 'pattern' qcon { unitOL (LL (IEVar (unLoc $2))) }
+ | 'module' modid { unitOL (sLL $1 $> (IEModuleContents (unLoc $2))) }
+ | 'pattern' qcon { unitOL (sLL $1 $> (IEVar (unLoc $2))) }
export_subspec :: { Located ImpExpSubSpec }
- : {- empty -} { L0 ImpExpAbs }
- | '(' '..' ')' { LL ImpExpAll }
- | '(' ')' { LL (ImpExpList []) }
- | '(' qcnames ')' { LL (ImpExpList (reverse $2)) }
+ : {- empty -} { sL0 ImpExpAbs }
+ | '(' '..' ')' { sLL $1 $> ImpExpAll }
+ | '(' ')' { sLL $1 $> (ImpExpList []) }
+ | '(' qcnames ')' { sLL $1 $> (ImpExpList (reverse $2)) }
qcnames :: { [RdrName] } -- A reversed list
: qcnames ',' qcname_ext { unLoc $3 : $1 }
@@ -523,7 +529,7 @@ qcnames :: { [RdrName] } -- A reversed list
qcname_ext :: { Located RdrName } -- Variable or data constructor
-- or tagged type constructor
: qcname { $1 }
- | 'type' qcname {% mkTypeImpExp (LL (unLoc $2)) }
+ | 'type' qcname {% mkTypeImpExp (sLL $1 $> (unLoc $2)) }
-- Cannot pull into qcname_ext, as qcname is also used in expression.
qcname :: { Located RdrName } -- Variable or data constructor
@@ -567,32 +573,32 @@ optqualified :: { Bool }
| {- empty -} { False }
maybeas :: { Located (Maybe ModuleName) }
- : 'as' modid { LL (Just (unLoc $2)) }
+ : 'as' modid { sLL $1 $> (Just (unLoc $2)) }
| {- empty -} { noLoc Nothing }
maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) }
- : impspec { L1 (Just (unLoc $1)) }
+ : impspec { sL1 $1 (Just (unLoc $1)) }
| {- empty -} { noLoc Nothing }
impspec :: { Located (Bool, [LIE RdrName]) }
- : '(' exportlist ')' { LL (False, fromOL $2) }
- | 'hiding' '(' exportlist ')' { LL (True, fromOL $3) }
+ : '(' exportlist ')' { sLL $1 $> (False, fromOL $2) }
+ | 'hiding' '(' exportlist ')' { sLL $1 $> (True, fromOL $3) }
-----------------------------------------------------------------------------
-- Fixity Declarations
prec :: { Int }
: {- empty -} { 9 }
- | INTEGER {% checkPrecP (L1 (fromInteger (getINTEGER $1))) }
+ | INTEGER {% checkPrecP (sL1 $1 (fromInteger (getINTEGER $1))) }
infix :: { Located FixityDirection }
- : 'infix' { L1 InfixN }
- | 'infixl' { L1 InfixL }
- | 'infixr' { L1 InfixR }
+ : 'infix' { sL1 $1 InfixN }
+ | 'infixl' { sL1 $1 InfixL }
+ | 'infixr' { sL1 $1 InfixR }
ops :: { Located [Located RdrName] }
- : ops ',' op { LL ($3 : unLoc $1) }
- | op { L1 [$1] }
+ : ops ',' op { sLL $1 $> ($3 : unLoc $1) }
+ | op { sL1 $1 [$1] }
-----------------------------------------------------------------------------
-- Top-Level Declarations
@@ -603,31 +609,31 @@ topdecls :: { OrdList (LHsDecl RdrName) }
| topdecl { $1 }
topdecl :: { OrdList (LHsDecl RdrName) }
- : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | inst_decl { unitOL (L1 (InstD (unLoc $1))) }
- | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
- | role_annot { unitOL (L1 (RoleAnnotD (unLoc $1))) }
- | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
- | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
+ : cl_decl { unitOL (sL1 $1 (TyClD (unLoc $1))) }
+ | ty_decl { unitOL (sL1 $1 (TyClD (unLoc $1))) }
+ | inst_decl { unitOL (sL1 $1 (InstD (unLoc $1))) }
+ | stand_alone_deriving { unitOL (sLL $1 $> (DerivD (unLoc $1))) }
+ | role_annot { unitOL (sL1 $1 (RoleAnnotD (unLoc $1))) }
+ | 'default' '(' comma_types0 ')' { unitOL (sLL $1 $> $ DefD (DefaultDecl $3)) }
+ | 'foreign' fdecl { unitOL (sLL $1 $> (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
- | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 $4) }
- | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) }
+ | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ sLL $1 $> $ VectD (HsVect $2 $4) }
+ | '{-# NOVECTORISE' qvar '#-}' { unitOL $ sLL $1 $> $ VectD (HsNoVect $2) }
| '{-# VECTORISE' 'type' gtycon '#-}'
- { unitOL $ LL $
+ { unitOL $ sLL $1 $> $
VectD (HsVectTypeIn False $3 Nothing) }
| '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
- { unitOL $ LL $
+ { unitOL $ sLL $1 $> $
VectD (HsVectTypeIn True $3 Nothing) }
| '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
- { unitOL $ LL $
+ { unitOL $ sLL $1 $> $
VectD (HsVectTypeIn False $3 (Just $5)) }
| '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
- { unitOL $ LL $
+ { unitOL $ sLL $1 $> $
VectD (HsVectTypeIn True $3 (Just $5)) }
- | '{-# VECTORISE' 'class' gtycon '#-}' { unitOL $ LL $ VectD (HsVectClassIn $3) }
+ | '{-# VECTORISE' 'class' gtycon '#-}' { unitOL $ sLL $1 $> $ VectD (HsVectClassIn $3) }
| annotation { unitOL $1 }
| decl_no_th { unLoc $1 }
@@ -635,7 +641,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
-- 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 $ mkSpliceDecl $1) }
+ | infixexp { unitOL (sLL $1 $> $ mkSpliceDecl $1) }
-- Type classes
--
@@ -720,25 +726,25 @@ overlap_pragma :: { Maybe OverlapMode }
where_type_family :: { Located (FamilyInfo RdrName) }
: {- empty -} { noLoc OpenTypeFamily }
| 'where' ty_fam_inst_eqn_list
- { LL (ClosedTypeFamily (reverse (unLoc $2))) }
+ { sLL $1 $> (ClosedTypeFamily (reverse (unLoc $2))) }
ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] }
- : '{' ty_fam_inst_eqns '}' { LL (unLoc $2) }
+ : '{' ty_fam_inst_eqns '}' { sLL $1 $> (unLoc $2) }
| vocurly ty_fam_inst_eqns close { $2 }
- | '{' '..' '}' { LL [] }
+ | '{' '..' '}' { sLL $1 $> [] }
| vocurly '..' close { let L loc _ = $2 in L loc [] }
ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] }
- : ty_fam_inst_eqns ';' ty_fam_inst_eqn { LL ($3 : unLoc $1) }
- | ty_fam_inst_eqns ';' { LL (unLoc $1) }
- | ty_fam_inst_eqn { LL [$1] }
+ : ty_fam_inst_eqns ';' ty_fam_inst_eqn { sLL $1 $> ($3 : unLoc $1) }
+ | ty_fam_inst_eqns ';' { sLL $1 $> (unLoc $1) }
+ | ty_fam_inst_eqn { sLL $1 $> [$1] }
ty_fam_inst_eqn :: { LTyFamInstEqn RdrName }
: type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
{% do { eqn <- mkTyFamInstEqn $1 $3
- ; return (LL eqn) } }
+ ; return (sLL $1 $> eqn) } }
-- Associated type family declarations
--
@@ -793,12 +799,12 @@ at_decl_inst :: { LInstDecl RdrName }
(unLoc $4) (unLoc $5) (unLoc $6) }
data_or_newtype :: { Located NewOrData }
- : 'data' { L1 DataType }
- | 'newtype' { L1 NewType }
+ : 'data' { sL1 $1 DataType }
+ | 'newtype' { sL1 $1 NewType }
opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
: { noLoc Nothing }
- | '::' kind { LL (Just $2) }
+ | '::' kind { sLL $1 $> (Just $2) }
-- tycl_hdr parses the header of a class or data type decl,
-- which takes the form
@@ -808,8 +814,8 @@ opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
- : context '=>' type { LL (Just $1, $3) }
- | type { L1 (Nothing, $1) }
+ : context '=>' type { sLL $1 $> (Just $1, $3) }
+ | type { sL1 $1 (Nothing, $1) }
capi_ctype :: { Maybe CType }
capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) }
@@ -821,7 +827,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTR
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
- : 'deriving' 'instance' overlap_pragma inst_type { LL (DerivDecl $4 $3) }
+ : 'deriving' 'instance' overlap_pragma inst_type { sLL $1 $> (DerivDecl $4 $3) }
-----------------------------------------------------------------------------
-- Role annotations
@@ -836,13 +842,13 @@ maybe_roles : {- empty -} { noLoc [] }
| roles { $1 }
roles :: { Located [Located (Maybe FastString)] }
-roles : role { LL [$1] }
- | roles role { LL $ $2 : unLoc $1 }
+roles : role { sLL $1 $> [$1] }
+ | roles role { sLL $1 $> $ $2 : unLoc $1 }
-- read it in as a varid for better error messages
role :: { Located (Maybe FastString) }
-role : VARID { L1 $ Just $ getVARID $1 }
- | '_' { L1 Nothing }
+role : VARID { sL1 $1 $ Just $ getVARID $1 }
+ | '_' { sL1 $1 Nothing }
-- Pattern synonyms
@@ -850,16 +856,16 @@ role : VARID { L1 $ Just $ getVARID $1 }
pattern_synonym_decl :: { LHsDecl RdrName }
: 'pattern' pat '=' pat
{% do { (name, args) <- splitPatSyn $2
- ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional
+ ; return $ sLL $1 $> . ValD $ mkPatSynBind name args $4 ImplicitBidirectional
}}
| 'pattern' pat '<-' pat
{% do { (name, args) <- splitPatSyn $2
- ; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional
+ ; return $ sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional
}}
| 'pattern' pat '<-' pat where_decls
{% do { (name, args) <- splitPatSyn $2
; mg <- toPatSynMatchGroup name $5
- ; return $ LL . ValD $
+ ; return $ sLL $1 $> . ValD $
mkPatSynBind name args $4 (ExplicitBidirectional mg)
}}
@@ -877,24 +883,24 @@ vars0 :: { [Located RdrName] }
-- Declaration in class bodies
--
decl_cls :: { Located (OrdList (LHsDecl RdrName)) }
-decl_cls : at_decl_cls { LL (unitOL $1) }
+decl_cls : at_decl_cls { sLL $1 $> (unitOL $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))) } }
+ ; return (sLL $1 $> $ unitOL (sLL $1 $> $ 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) }
+ : decls_cls ';' decl_cls { sLL $1 $> (unLoc $1 `appOL` unLoc $3) }
+ | decls_cls ';' { sLL $1 $> (unLoc $1) }
| decl_cls { $1 }
| {- empty -} { noLoc nilOL }
decllist_cls
:: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
- : '{' decls_cls '}' { LL (unLoc $2) }
+ : '{' decls_cls '}' { sLL $1 $> (unLoc $2) }
| vocurly decls_cls close { $2 }
-- Class body
@@ -902,24 +908,24 @@ decllist_cls
where_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
-- No implicit parameters
-- May have type declarations
- : 'where' decllist_cls { LL (unLoc $2) }
+ : 'where' decllist_cls { sLL $1 $> (unLoc $2) }
| {- empty -} { noLoc nilOL }
-- Declarations in instance bodies
--
decl_inst :: { Located (OrdList (LHsDecl RdrName)) }
-decl_inst : at_decl_inst { LL (unitOL (L1 (InstD (unLoc $1)))) }
+decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD (unLoc $1)))) }
| decl { $1 }
decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
- : decls_inst ';' decl_inst { LL (unLoc $1 `appOL` unLoc $3) }
- | decls_inst ';' { LL (unLoc $1) }
+ : decls_inst ';' decl_inst { sLL $1 $> (unLoc $1 `appOL` unLoc $3) }
+ | decls_inst ';' { sLL $1 $> (unLoc $1) }
| decl_inst { $1 }
| {- empty -} { noLoc nilOL }
decllist_inst
:: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
- : '{' decls_inst '}' { LL (unLoc $2) }
+ : '{' decls_inst '}' { sLL $1 $> (unLoc $2) }
| vocurly decls_inst close { $2 }
-- Instance body
@@ -927,7 +933,7 @@ decllist_inst
where_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
-- No implicit parameters
-- May have type declarations
- : 'where' decllist_inst { LL (unLoc $2) }
+ : 'where' decllist_inst { sLL $1 $> (unLoc $2) }
| {- empty -} { noLoc nilOL }
-- Declarations in binding groups other than classes and instances
@@ -937,26 +943,26 @@ decls :: { Located (OrdList (LHsDecl RdrName)) }
rest = unLoc $1;
these = rest `appOL` this }
in rest `seq` this `seq` these `seq`
- LL these }
- | decls ';' { LL (unLoc $1) }
+ sLL $1 $> these }
+ | decls ';' { sLL $1 $> (unLoc $1) }
| decl { $1 }
| {- empty -} { noLoc nilOL }
decllist :: { Located (OrdList (LHsDecl RdrName)) }
- : '{' decls '}' { LL (unLoc $2) }
+ : '{' decls '}' { sLL $1 $> (unLoc $2) }
| vocurly decls close { $2 }
-- Binding groups other than those of class and instance declarations
--
binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
-- No type declarations
- : decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
- | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
+ : decllist { sL1 $1 (HsValBinds (cvBindGroup (unLoc $1))) }
+ | '{' dbinds '}' { sLL $1 $> (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
- : 'where' binds { LL (unLoc $2) }
+ : 'where' binds { sLL $1 $> (unLoc $2) }
| {- empty -} { noLoc emptyLocalBinds }
@@ -971,7 +977,7 @@ rules :: { OrdList (LHsDecl RdrName) }
rule :: { LHsDecl RdrName }
: STRING rule_activation rule_forall infixexp '=' exp
- { LL $ RuleD (HsRule (getSTRING $1)
+ { sLL $1 $> $ RuleD (HsRule (getSTRING $1)
($2 `orElse` AlwaysActive)
$3 $4 placeHolderNames $6 placeHolderNames) }
@@ -1009,7 +1015,7 @@ warnings :: { OrdList (LHsDecl RdrName) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LHsDecl RdrName) }
: namelist strings
- { toOL [ LL $ WarningD (Warning n (WarningTxt $ unLoc $2))
+ { toOL [ sLL $1 $> $ WarningD (Warning n (WarningTxt $ unLoc $2))
| n <- unLoc $1 ] }
deprecations :: { OrdList (LHsDecl RdrName) }
@@ -1021,23 +1027,23 @@ deprecations :: { OrdList (LHsDecl RdrName) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { OrdList (LHsDecl RdrName) }
: namelist strings
- { toOL [ LL $ WarningD (Warning n (DeprecatedTxt $ unLoc $2))
+ { toOL [ sLL $1 $> $ WarningD (Warning n (DeprecatedTxt $ unLoc $2))
| n <- unLoc $1 ] }
strings :: { Located [FastString] }
- : STRING { L1 [getSTRING $1] }
- | '[' stringlist ']' { LL $ fromOL (unLoc $2) }
+ : STRING { sL1 $1 [getSTRING $1] }
+ | '[' stringlist ']' { sLL $1 $> $ fromOL (unLoc $2) }
stringlist :: { Located (OrdList FastString) }
- : stringlist ',' STRING { LL (unLoc $1 `snocOL` getSTRING $3) }
- | STRING { LL (unitOL (getSTRING $1)) }
+ : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL` getSTRING $3) }
+ | STRING { sLL $1 $> (unitOL (getSTRING $1)) }
-----------------------------------------------------------------------------
-- 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) }
+ : '{-# ANN' name_var aexp '#-}' { sLL $1 $> (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) }
+ | '{-# ANN' 'type' tycon aexp '#-}' { sLL $1 $> (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) }
+ | '{-# ANN' 'module' aexp '#-}' { sLL $1 $> (AnnD $ HsAnnotation ModuleAnnProvenance $3) }
-----------------------------------------------------------------------------
@@ -1045,12 +1051,12 @@ annotation :: { LHsDecl RdrName }
fdecl :: { LHsDecl RdrName }
fdecl : 'import' callconv safety fspec
- {% mkImport $2 $3 (unLoc $4) >>= return.LL }
+ {% mkImport $2 $3 (unLoc $4) >>= return.sLL $1 $> }
| 'import' callconv fspec
{% do { d <- mkImport $2 PlaySafe (unLoc $3);
- return (LL d) } }
+ return (sLL $1 $> d) } }
| 'export' callconv fspec
- {% mkExport $2 (unLoc $3) >>= return.LL }
+ {% mkExport $2 (unLoc $3) >>= return.sLL $1 $> }
callconv :: { CCallConv }
: 'stdcall' { StdCallConv }
@@ -1065,8 +1071,8 @@ safety :: { Safety }
| 'interruptible' { PlayInterruptible }
fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
- : STRING var '::' sigtypedoc { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
- | var '::' sigtypedoc { LL (noLoc nilFS, $1, $3) }
+ : STRING var '::' sigtypedoc { sLL $1 $> (L (getLoc $1) (getSTRING $1), $2, $4) }
+ | var '::' sigtypedoc { sLL $1 $> (noLoc nilFS, $1, $3) }
-- if the entity string is missing, it defaults to the empty string;
-- the meaning of an empty entity string depends on the calling
-- convention
@@ -1084,16 +1090,16 @@ opt_asig :: { Maybe (LHsType RdrName) }
sigtype :: { LHsType RdrName } -- Always a HsForAllTy,
-- to tell the renamer where to generalise
- : ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
+ : ctype { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy
- : ctypedoc { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
+ : ctypedoc { sL1 $1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
sig_vars :: { Located [Located RdrName] } -- Returned in reversed order
- : sig_vars ',' var { LL ($3 : unLoc $1) }
- | var { L1 [$1] }
+ : sig_vars ',' var { sLL $1 $> ($3 : unLoc $1) }
+ | var { sL1 $1 [$1] }
sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys
: sigtype { [ $1 ] }
@@ -1103,20 +1109,20 @@ sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys
-- Types
strict_mark :: { Located HsBang }
- : '!' { L1 (HsUserBang Nothing True) }
- | '{-# UNPACK' '#-}' { LL (HsUserBang (Just True) False) }
- | '{-# NOUNPACK' '#-}' { LL (HsUserBang (Just False) True) }
- | '{-# UNPACK' '#-}' '!' { LL (HsUserBang (Just True) True) }
- | '{-# NOUNPACK' '#-}' '!' { LL (HsUserBang (Just False) True) }
+ : '!' { sL1 $1 (HsUserBang Nothing True) }
+ | '{-# UNPACK' '#-}' { sLL $1 $> (HsUserBang (Just True) False) }
+ | '{-# NOUNPACK' '#-}' { sLL $1 $> (HsUserBang (Just False) True) }
+ | '{-# UNPACK' '#-}' '!' { sLL $1 $> (HsUserBang (Just True) True) }
+ | '{-# NOUNPACK' '#-}' '!' { sLL $1 $> (HsUserBang (Just False) True) }
-- Although UNPACK with no '!' is illegal, we get a
-- better error message if we parse it here
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >>
- return (LL $ mkExplicitHsForAllTy $2 (noLoc []) $4) }
- | context '=>' ctype { LL $ mkQualifiedHsForAllTy $1 $3 }
- | ipvar '::' type { LL (HsIParamTy (unLoc $1) $3) }
+ return (sLL $1 $> $ mkExplicitHsForAllTy $2 (noLoc []) $4) }
+ | context '=>' ctype { sLL $1 $> $ mkQualifiedHsForAllTy $1 $3 }
+ | ipvar '::' type { sLL $1 $> (HsIParamTy (unLoc $1) $3) }
| type { $1 }
----------------------
@@ -1132,9 +1138,9 @@ ctype :: { LHsType RdrName }
ctypedoc :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >>
- return (LL $ mkExplicitHsForAllTy $2 (noLoc []) $4) }
- | context '=>' ctypedoc { LL $ mkQualifiedHsForAllTy $1 $3 }
- | ipvar '::' type { LL (HsIParamTy (unLoc $1) $3) }
+ return (sLL $1 $> $ mkExplicitHsForAllTy $2 (noLoc []) $4) }
+ | context '=>' ctypedoc { sLL $1 $> $ mkQualifiedHsForAllTy $1 $3 }
+ | ipvar '::' type { sLL $1 $> (HsIParamTy (unLoc $1) $3) }
| typedoc { $1 }
----------------------
@@ -1150,65 +1156,65 @@ ctypedoc :: { LHsType RdrName }
-- but not f :: ?x::Int => blah
context :: { LHsContext RdrName }
: btype '~' btype {% checkContext
- (LL $ HsEqTy $1 $3) }
+ (sLL $1 $> $ HsEqTy $1 $3) }
| btype {% checkContext $1 }
type :: { LHsType RdrName }
: btype { $1 }
- | btype qtyconop type { LL $ mkHsOpTy $1 $2 $3 }
- | btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 }
- | btype '->' ctype { LL $ HsFunTy $1 $3 }
- | btype '~' btype { LL $ HsEqTy $1 $3 }
+ | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
+ | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
+ | btype '->' ctype { sLL $1 $> $ HsFunTy $1 $3 }
+ | btype '~' btype { sLL $1 $> $ HsEqTy $1 $3 }
-- see Note [Promotion]
- | btype SIMPLEQUOTE qconop type { LL $ mkHsOpTy $1 $3 $4 }
- | btype SIMPLEQUOTE varop type { LL $ mkHsOpTy $1 $3 $4 }
+ | btype SIMPLEQUOTE qconop type { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
+ | btype SIMPLEQUOTE varop type { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
typedoc :: { LHsType RdrName }
: btype { $1 }
- | btype docprev { LL $ HsDocTy $1 $2 }
- | btype qtyconop type { LL $ mkHsOpTy $1 $2 $3 }
- | btype qtyconop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
- | btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 }
- | btype tyvarop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
- | btype '->' ctypedoc { LL $ HsFunTy $1 $3 }
- | btype docprev '->' ctypedoc { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
- | btype '~' btype { LL $ HsEqTy $1 $3 }
+ | btype docprev { sLL $1 $> $ HsDocTy $1 $2 }
+ | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
+ | btype qtyconop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
+ | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
+ | btype tyvarop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
+ | btype '->' ctypedoc { sLL $1 $> $ HsFunTy $1 $3 }
+ | btype docprev '->' ctypedoc { sLL $1 $> $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
+ | btype '~' btype { sLL $1 $> $ HsEqTy $1 $3 }
-- see Note [Promotion]
- | btype SIMPLEQUOTE qconop type { LL $ mkHsOpTy $1 $3 $4 }
- | btype SIMPLEQUOTE varop type { LL $ mkHsOpTy $1 $3 $4 }
+ | btype SIMPLEQUOTE qconop type { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
+ | btype SIMPLEQUOTE varop type { sLL $1 $> $ mkHsOpTy $1 $3 $4 }
btype :: { LHsType RdrName }
- : btype atype { LL $ HsAppTy $1 $2 }
+ : btype atype { sLL $1 $> $ HsAppTy $1 $2 }
| atype { $1 }
atype :: { LHsType RdrName }
- : ntgtycon { L1 (HsTyVar (unLoc $1)) } -- Not including unit tuples
- | tyvar { L1 (HsTyVar (unLoc $1)) } -- (See Note [Unit tuples])
- | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only
- | '{' fielddecls '}' {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only
- | '(' ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple [] }
- | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) }
- | '(#' '#)' { LL $ HsTupleTy HsUnboxedTuple [] }
- | '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 }
- | '[' ctype ']' { LL $ HsListTy $2 }
- | '[:' ctype ':]' { LL $ HsPArrTy $2 }
- | '(' ctype ')' { LL $ HsParTy $2 }
- | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 }
- | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) }
- | '$(' exp ')' { LL $ mkHsSpliceTy $2 }
- | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
+ : ntgtycon { sL1 $1 (HsTyVar (unLoc $1)) } -- Not including unit tuples
+ | tyvar { sL1 $1 (HsTyVar (unLoc $1)) } -- (See Note [Unit tuples])
+ | strict_mark atype { sLL $1 $> (HsBangTy (unLoc $1) $2) } -- Constructor sigs only
+ | '{' fielddecls '}' {% checkRecordSyntax (sLL $1 $> $ HsRecTy $2) } -- Constructor sigs only
+ | '(' ')' { sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple [] }
+ | '(' ctype ',' comma_types1 ')' { sLL $1 $> $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) }
+ | '(#' '#)' { sLL $1 $> $ HsTupleTy HsUnboxedTuple [] }
+ | '(#' comma_types1 '#)' { sLL $1 $> $ HsTupleTy HsUnboxedTuple $2 }
+ | '[' ctype ']' { sLL $1 $> $ HsListTy $2 }
+ | '[:' ctype ':]' { sLL $1 $> $ HsPArrTy $2 }
+ | '(' ctype ')' { sLL $1 $> $ HsParTy $2 }
+ | '(' ctype '::' kind ')' { sLL $1 $> $ HsKindSig $2 $4 }
+ | quasiquote { sL1 $1 (HsQuasiQuoteTy (unLoc $1)) }
+ | '$(' exp ')' { sLL $1 $> $ mkHsSpliceTy $2 }
+ | TH_ID_SPLICE { sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $
mkUnqual varName (getTH_ID_SPLICE $1) }
-- see Note [Promotion] for the followings
- | SIMPLEQUOTE qcon { LL $ HsTyVar $ unLoc $2 }
- | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) }
- | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy
+ | SIMPLEQUOTE qcon { sLL $1 $> $ HsTyVar $ unLoc $2 }
+ | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5) }
+ | SIMPLEQUOTE '[' comma_types0 ']' { sLL $1 $> $ HsExplicitListTy
placeHolderKind $3 }
- | SIMPLEQUOTE var { LL $ HsTyVar $ unLoc $2 }
+ | SIMPLEQUOTE var { sLL $1 $> $ HsTyVar $ unLoc $2 }
- | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy
+ | '[' ctype ',' comma_types1 ']' { sLL $1 $> $ HsExplicitListTy
placeHolderKind ($2 : $4) }
- | INTEGER { LL $ HsTyLit $ HsNumTy $ getINTEGER $1 }
- | STRING { LL $ HsTyLit $ HsStrTy $ getSTRING $1 }
+ | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy $ getINTEGER $1 }
+ | STRING { sLL $1 $> $ HsTyLit $ HsStrTy $ getSTRING $1 }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
@@ -1234,16 +1240,16 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
- : tyvar { L1 (UserTyVar (unLoc $1)) }
- | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) }
+ : tyvar { sL1 $1 (UserTyVar (unLoc $1)) }
+ | '(' tyvar '::' kind ')' { sLL $1 $> (KindedTyVar (unLoc $2) $4) }
fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
- | '|' fds1 { LL (reverse (unLoc $2)) }
+ | '|' fds1 { sLL $1 $> (reverse (unLoc $2)) }
fds1 :: { Located [Located (FunDep RdrName)] }
- : fds1 ',' fd { LL ($3 : unLoc $1) }
- | fd { L1 [$1] }
+ : fds1 ',' fd { sLL $1 $> ($3 : unLoc $1) }
+ | fd { sL1 $1 [$1] }
fd :: { Located (FunDep RdrName) }
: varids0 '->' varids0 { L (comb3 $1 $2 $3)
@@ -1251,30 +1257,30 @@ fd :: { Located (FunDep RdrName) }
varids0 :: { Located [RdrName] }
: {- empty -} { noLoc [] }
- | varids0 tyvar { LL (unLoc $2 : unLoc $1) }
+ | varids0 tyvar { sLL $1 $> (unLoc $2 : unLoc $1) }
-----------------------------------------------------------------------------
-- Kinds
kind :: { LHsKind RdrName }
: bkind { $1 }
- | bkind '->' kind { LL $ HsFunTy $1 $3 }
+ | bkind '->' kind { sLL $1 $> $ HsFunTy $1 $3 }
bkind :: { LHsKind RdrName }
: akind { $1 }
- | bkind akind { LL $ HsAppTy $1 $2 }
+ | bkind akind { sLL $1 $> $ HsAppTy $1 $2 }
akind :: { LHsKind RdrName }
- : '*' { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
- | '(' kind ')' { LL $ HsParTy $2 }
+ : '*' { sL1 $1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) }
+ | '(' kind ')' { sLL $1 $> $ HsParTy $2 }
| pkind { $1 }
- | tyvar { L1 $ HsTyVar (unLoc $1) }
+ | tyvar { sL1 $1 $ HsTyVar (unLoc $1) }
pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion]
- : qtycon { L1 $ HsTyVar $ unLoc $1 }
- | '(' ')' { LL $ HsTyVar $ getRdrName unitTyCon }
- | '(' kind ',' comma_kinds1 ')' { LL $ HsTupleTy HsBoxedTuple ($2 : $4) }
- | '[' kind ']' { LL $ HsListTy $2 }
+ : qtycon { sL1 $1 $ HsTyVar $ unLoc $1 }
+ | '(' ')' { sLL $1 $> $ HsTyVar $ getRdrName unitTyCon }
+ | '(' kind ',' comma_kinds1 ')' { sLL $1 $> $ HsTupleTy HsBoxedTuple ($2 : $4) }
+ | '[' kind ']' { sLL $1 $> $ HsListTy $2 }
comma_kinds1 :: { [LHsKind RdrName] }
: kind { [$1] }
@@ -1341,8 +1347,8 @@ constrs :: { Located [LConDecl RdrName] }
: 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) }
- | constr { L1 [$1] }
+ : constrs1 maybe_docnext '|' maybe_docprev constr { sLL $1 $> (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4) }
+ | constr { sL1 $1 [$1] }
constr :: { LConDecl RdrName }
: maybe_docnext forall context '=>' constr_stuff maybe_docprev
@@ -1355,7 +1361,7 @@ constr :: { LConDecl RdrName }
($1 `mplus` $4) }
forall :: { Located [LHsTyVarBndr RdrName] }
- : 'forall' tv_bndrs '.' { LL $2 }
+ : 'forall' tv_bndrs '.' { sLL $1 $> $2 }
| {- empty -} { noLoc [] }
constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
@@ -1366,8 +1372,8 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
-- C t1 t2 %: D Int
-- in which case C really would be a type constructor. We can't resolve this
-- ambiguity till we come across the constructor oprerator :% (or not, more usually)
- : btype {% splitCon $1 >>= return.LL }
- | btype conop btype { LL ($2, InfixCon $1 $3) }
+ : btype {% splitCon $1 >>= return.sLL $1 $> }
+ | btype conop btype { sLL $1 $> ($2, InfixCon $1 $3) }
fielddecls :: { [ConDeclField RdrName] }
: {- empty -} { [] }
@@ -1390,9 +1396,9 @@ fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int
deriving :: { Located (Maybe [LHsType RdrName]) }
: {- empty -} { noLoc Nothing }
| 'deriving' qtycon { let { L loc tv = $2 }
- in LL (Just [L loc (HsTyVar tv)]) }
- | 'deriving' '(' ')' { LL (Just []) }
- | 'deriving' '(' inst_types1 ')' { LL (Just $3) }
+ in sLL $1 $> (Just [L loc (HsTyVar tv)]) }
+ | 'deriving' '(' ')' { sLL $1 $> (Just []) }
+ | 'deriving' '(' inst_types1 ')' { sLL $1 $> (Just $3) }
-- Glasgow extension: allow partial
-- applications in derivings
@@ -1422,20 +1428,20 @@ There's an awkward overlap with a type signature. Consider
-}
docdecl :: { LHsDecl RdrName }
- : docdecld { L1 (DocD (unLoc $1)) }
+ : docdecld { sL1 $1 (DocD (unLoc $1)) }
docdecld :: { LDocDecl }
- : docnext { L1 (DocCommentNext (unLoc $1)) }
- | docprev { L1 (DocCommentPrev (unLoc $1)) }
- | docnamed { L1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }
- | docsection { L1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) }
+ : docnext { sL1 $1 (DocCommentNext (unLoc $1)) }
+ | docprev { sL1 $1 (DocCommentPrev (unLoc $1)) }
+ | docnamed { sL1 $1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }
+ | docsection { sL1 $1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) }
decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
: sigdecl { $1 }
- | '!' aexp rhs {% do { let { e = LL (SectionR (LL (HsVar bang_RDR)) $2) };
+ | '!' aexp rhs {% do { let { e = sLL $1 $> (SectionR (sLL $1 $> (HsVar bang_RDR)) $2) };
pat <- checkPattern empty e;
- return $ LL $ unitOL $ LL $ ValD $
+ return $ sLL $1 $> $ unitOL $ sLL $1 $> $ ValD $
PatBind pat (unLoc $3)
placeHolderType
placeHolderNames
@@ -1446,8 +1452,8 @@ decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
| infixexp opt_sig rhs {% do { r <- checkValDef empty $1 $2 $3;
let { l = comb2 $1 $> };
return $! (sL l (unitOL $! (sL l $ ValD r))) } }
- | pattern_synonym_decl { LL $ unitOL $1 }
- | docdecl { LL $ unitOL $1 }
+ | pattern_synonym_decl { sLL $1 $> $ unitOL $1 }
+ | docdecl { sLL $1 $> $ unitOL $1 }
decl :: { Located (OrdList (LHsDecl RdrName)) }
: decl_no_th { $1 }
@@ -1455,15 +1461,15 @@ decl :: { Located (OrdList (LHsDecl RdrName)) }
-- Why do we only allow naked declaration splices in top-level
-- declarations and not here? Short answer: because readFail009
-- fails terribly with a panic in cvBindsAndSigs otherwise.
- | splice_exp { LL $ unitOL (LL $ mkSpliceDecl $1) }
+ | splice_exp { sLL $1 $> $ unitOL (sLL $1 $> $ mkSpliceDecl $1) }
rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) }
: '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
- | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
+ | gdrhs wherebinds { sLL $1 $> $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
gdrhs :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
- : gdrhs gdrh { LL ($2 : unLoc $1) }
- | gdrh { L1 [$1] }
+ : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) }
+ | gdrh { sL1 $1 [$1] }
gdrh :: { LGRHS RdrName (LHsExpr RdrName) }
: '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
@@ -1473,25 +1479,25 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
-- See Note [Declaration/signature overlap] for why we need infixexp here
infixexp '::' sigtypedoc
{% do s <- checkValSig $1 $3
- ; return (LL $ unitOL (LL $ SigD s)) }
+ ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) }
| var ',' sig_vars '::' sigtypedoc
- { LL $ toOL [ LL $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
- | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
+ { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
+ | infix prec ops { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| n <- unLoc $3 ] }
| '{-# INLINE' activation qvar '#-}'
- { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
+ { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
{ let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2
- in LL $ toOL [ LL $ SigD (SpecSig $3 t inl_prag)
+ in sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t inl_prag)
| t <- $5] }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
+ { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
| t <- $5] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
- { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
+ { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3)) }
-- A minimal complete definition
| '{-# MINIMAL' name_boolformula_opt '#-}'
- { LL $ unitOL (LL $ SigD (MinimalSig $2)) }
+ { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (MinimalSig $2)) }
activation :: { Maybe Activation }
: {- empty -} { Nothing }
@@ -1508,66 +1514,66 @@ quasiquote :: { Located (HsQuasiQuote RdrName) }
: TH_QUASIQUOTE { let { loc = getLoc $1
; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkUnqual varName quoter }
- in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
+ in sL1 $1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
| TH_QQUASIQUOTE { let { loc = getLoc $1
; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkQual varName (qual, quoter) }
in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
exp :: { LHsExpr RdrName }
- : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
- | infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType
+ : infixexp '::' sigtype { sLL $1 $> $ ExprWithTySig $1 $3 }
+ | infixexp '-<' exp { sLL $1 $> $ HsArrApp $1 $3 placeHolderType
HsFirstOrderApp True }
- | infixexp '>-' exp { LL $ HsArrApp $3 $1 placeHolderType
+ | infixexp '>-' exp { sLL $1 $> $ HsArrApp $3 $1 placeHolderType
HsFirstOrderApp False }
- | infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType
+ | infixexp '-<<' exp { sLL $1 $> $ HsArrApp $1 $3 placeHolderType
HsHigherOrderApp True }
- | infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType
+ | infixexp '>>-' exp { sLL $1 $> $ HsArrApp $3 $1 placeHolderType
HsHigherOrderApp False}
| infixexp { $1 }
infixexp :: { LHsExpr RdrName }
: exp10 { $1 }
- | infixexp qop exp10 { LL (OpApp $1 $2 placeHolderFixity $3) }
+ | infixexp qop exp10 { sLL $1 $> (OpApp $1 $2 placeHolderFixity $3) }
exp10 :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp
- { LL $ HsLam (mkMatchGroup FromSource [LL $ Match ($2:$3) $4
+ { sLL $1 $> $ HsLam (mkMatchGroup FromSource [sLL $1 $> $ Match ($2:$3) $4
(unguardedGRHSs $6)
]) }
- | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
+ | 'let' binds 'in' exp { sLL $1 $> $ HsLet (unLoc $2) $4 }
| '\\' 'lcase' altslist
- { LL $ HsLamCase placeHolderType (mkMatchGroup FromSource (unLoc $3)) }
+ { sLL $1 $> $ HsLamCase placeHolderType (mkMatchGroup FromSource (unLoc $3)) }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
- return (LL $ mkHsIf $2 $5 $8) }
+ return (sLL $1 $> $ mkHsIf $2 $5 $8) }
| 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>
- return (LL $ HsMultiIf
+ return (sLL $1 $> $ HsMultiIf
placeHolderType
(reverse $ unLoc $2)) }
- | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup FromSource (unLoc $4)) }
- | '-' fexp { LL $ NegApp $2 noSyntaxExpr }
+ | 'case' exp 'of' altslist { sLL $1 $> $ HsCase $2 (mkMatchGroup FromSource (unLoc $4)) }
+ | '-' fexp { sLL $1 $> $ NegApp $2 noSyntaxExpr }
| 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) }
| 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
| scc_annot exp {% do { on <- extension sccProfilingOn
- ; return $ LL $ if on
+ ; return $ sLL $1 $> $ if on
then HsSCC (unLoc $1) $2
else HsPar $2 } }
| hpc_annot exp {% do { on <- extension hpcEnabled
- ; return $ LL $ if on
+ ; return $ sLL $1 $> $ if on
then HsTickPragma (unLoc $1) $2
else HsPar $2 } }
| 'proc' aexp '->' exp
{% checkPattern empty $2 >>= \ p ->
checkCommand $4 >>= \ cmd ->
- return (LL $ HsProc p (LL $ HsCmdTop cmd placeHolderType
+ return (sLL $1 $> $ HsProc p (sLL $1 $> $ HsCmdTop cmd placeHolderType
placeHolderType [])) }
- -- TODO: is LL right here?
+ -- TODO: is sLL $1 $> right here?
- | '{-# CORE' STRING '#-}' exp { LL $ HsCoreAnn (getSTRING $2) $4 }
+ | '{-# CORE' STRING '#-}' exp { sLL $1 $> $ HsCoreAnn (getSTRING $2) $4 }
-- hdaume: core annotation
| fexp { $1 }
@@ -1576,12 +1582,12 @@ optSemi :: { Bool }
| {- empty -} { False }
scc_annot :: { Located FastString }
- : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2; return $ LL scc }
- | '{-# SCC' VARID '#-}' { LL (getVARID $2) }
+ : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2; return $ sLL $1 $> scc }
+ | '{-# SCC' VARID '#-}' { sLL $1 $> (getVARID $2) }
hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
: '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
- { LL $ (getSTRING $2
+ { sLL $1 $> $ (getSTRING $2
,( fromInteger $ getINTEGER $3
, fromInteger $ getINTEGER $5
)
@@ -1592,23 +1598,23 @@ hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
}
fexp :: { LHsExpr RdrName }
- : fexp aexp { LL $ HsApp $1 $2 }
+ : fexp aexp { sLL $1 $> $ HsApp $1 $2 }
| aexp { $1 }
aexp :: { LHsExpr RdrName }
- : qvar '@' aexp { LL $ EAsPat $1 $3 }
- | '~' aexp { LL $ ELazyPat $2 }
+ : qvar '@' aexp { sLL $1 $> $ EAsPat $1 $3 }
+ | '~' aexp { sLL $1 $> $ ELazyPat $2 }
| aexp1 { $1 }
aexp1 :: { LHsExpr RdrName }
: aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3
- ; checkRecordSyntax (LL r) }}
+ ; checkRecordSyntax (sLL $1 $> r) }}
| aexp2 { $1 }
aexp2 :: { LHsExpr RdrName }
- : ipvar { L1 (HsIPVar $! unLoc $1) }
- | qcname { L1 (HsVar $! unLoc $1) }
- | literal { L1 (HsLit $! unLoc $1) }
+ : ipvar { sL1 $1 (HsIPVar $! unLoc $1) }
+ | qcname { sL1 $1 (HsVar $! unLoc $1) }
+ | literal { sL1 $1 (HsLit $! unLoc $1) }
-- This will enable overloaded strings permanently. Normally the renamer turns HsString
-- into HsOverLit when -foverloaded-strings is on.
-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString
@@ -1622,43 +1628,43 @@ aexp2 :: { LHsExpr RdrName }
-- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
-- correct Haskell (you'd have to write '((+ 3), (4 -))')
-- but the less cluttered version fell out of having texps.
- | '(' texp ')' { LL (HsPar $2) }
- | '(' tup_exprs ')' { LL (ExplicitTuple $2 Boxed) }
+ | '(' texp ')' { sLL $1 $> (HsPar $2) }
+ | '(' tup_exprs ')' { sLL $1 $> (ExplicitTuple $2 Boxed) }
- | '(#' texp '#)' { LL (ExplicitTuple [Present $2] Unboxed) }
- | '(#' tup_exprs '#)' { LL (ExplicitTuple $2 Unboxed) }
+ | '(#' texp '#)' { sLL $1 $> (ExplicitTuple [Present $2] Unboxed) }
+ | '(#' tup_exprs '#)' { sLL $1 $> (ExplicitTuple $2 Unboxed) }
- | '[' list ']' { LL (unLoc $2) }
- | '[:' parr ':]' { LL (unLoc $2) }
- | '_' { L1 EWildPat }
+ | '[' list ']' { sLL $1 $> (unLoc $2) }
+ | '[:' parr ':]' { sLL $1 $> (unLoc $2) }
+ | '_' { sL1 $1 EWildPat }
-- Template Haskell Extension
| splice_exp { $1 }
- | SIMPLEQUOTE qvar { LL $ HsBracket (VarBr True (unLoc $2)) }
- | SIMPLEQUOTE qcon { LL $ HsBracket (VarBr True (unLoc $2)) }
- | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr False (unLoc $2)) }
- | TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr False (unLoc $2)) }
- | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) }
- | '[||' exp '||]' { LL $ HsBracket (TExpBr $2) }
- | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) }
+ | SIMPLEQUOTE qvar { sLL $1 $> $ HsBracket (VarBr True (unLoc $2)) }
+ | SIMPLEQUOTE qcon { sLL $1 $> $ HsBracket (VarBr True (unLoc $2)) }
+ | TH_TY_QUOTE tyvar { sLL $1 $> $ HsBracket (VarBr False (unLoc $2)) }
+ | TH_TY_QUOTE gtycon { sLL $1 $> $ HsBracket (VarBr False (unLoc $2)) }
+ | '[|' exp '|]' { sLL $1 $> $ HsBracket (ExpBr $2) }
+ | '[||' exp '||]' { sLL $1 $> $ HsBracket (TExpBr $2) }
+ | '[t|' ctype '|]' { sLL $1 $> $ HsBracket (TypBr $2) }
| '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p ->
- return (LL $ HsBracket (PatBr p)) }
- | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBrL $2) }
- | quasiquote { L1 (HsQuasiQuoteE (unLoc $1)) }
+ return (sLL $1 $> $ HsBracket (PatBr p)) }
+ | '[d|' cvtopbody '|]' { sLL $1 $> $ HsBracket (DecBrL $2) }
+ | quasiquote { sL1 $1 (HsQuasiQuoteE (unLoc $1)) }
-- arrow notation extension
- | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) }
+ | '(|' aexp2 cmdargs '|)' { sLL $1 $> $ HsArrForm $2 Nothing (reverse $3) }
splice_exp :: { LHsExpr RdrName }
- : TH_ID_SPLICE { L1 $ mkHsSpliceE
- (L1 $ HsVar (mkUnqual varName
- (getTH_ID_SPLICE $1))) }
- | '$(' exp ')' { LL $ mkHsSpliceE $2 }
- | TH_ID_TY_SPLICE { L1 $ mkHsSpliceTE
- (L1 $ HsVar (mkUnqual varName
- (getTH_ID_TY_SPLICE $1))) }
- | '$$(' exp ')' { LL $ mkHsSpliceTE $2 }
+ : TH_ID_SPLICE { sL1 $1 $ mkHsSpliceE
+ (sL1 $1 $ HsVar (mkUnqual varName
+ (getTH_ID_SPLICE $1))) }
+ | '$(' exp ')' { sLL $1 $> $ mkHsSpliceE $2 }
+ | TH_ID_TY_SPLICE { sL1 $1 $ mkHsSpliceTE
+ (sL1 $1 $ HsVar (mkUnqual varName
+ (getTH_ID_TY_SPLICE $1))) }
+ | '$$(' exp ')' { sLL $1 $> $ mkHsSpliceTE $2 }
cmdargs :: { [LHsCmdTop RdrName] }
: cmdargs acmd { $2 : $1 }
@@ -1666,7 +1672,7 @@ cmdargs :: { [LHsCmdTop RdrName] }
acmd :: { LHsCmdTop RdrName }
: aexp2 {% checkCommand $1 >>= \ cmd ->
- return (L1 $ HsCmdTop cmd
+ return (sL1 $1 $ HsCmdTop cmd
placeHolderType placeHolderType []) }
cvtopbody :: { [LHsDecl RdrName] }
@@ -1697,11 +1703,11 @@ texp :: { LHsExpr RdrName }
-- Then when converting expr to pattern we unravel it again
-- Meanwhile, the renamer checks that real sections appear
-- inside parens.
- | infixexp qop { LL $ SectionL $1 $2 }
- | qopm infixexp { LL $ SectionR $1 $2 }
+ | infixexp qop { sLL $1 $> $ SectionL $1 $2 }
+ | qopm infixexp { sLL $1 $> $ SectionR $1 $2 }
-- View patterns get parenthesized above
- | exp '->' texp { LL $ EViewPat $1 $3 }
+ | exp '->' texp { sLL $1 $> $ EViewPat $1 $3 }
-- Always at least one comma
tup_exprs :: { [HsTupArg RdrName] }
@@ -1725,32 +1731,32 @@ tup_tail :: { [HsTupArg RdrName] }
-- avoiding another shift/reduce-conflict.
list :: { LHsExpr RdrName }
- : texp { L1 $ ExplicitList placeHolderType Nothing [$1] }
- | lexps { L1 $ ExplicitList placeHolderType Nothing
+ : texp { sL1 $1 $ ExplicitList placeHolderType Nothing [$1] }
+ | lexps { sL1 $1 $ ExplicitList placeHolderType Nothing
(reverse (unLoc $1)) }
- | texp '..' { LL $ ArithSeq noPostTcExpr Nothing (From $1) }
- | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) }
- | texp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) }
- | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5) }
+ | texp '..' { sLL $1 $> $ ArithSeq noPostTcExpr Nothing (From $1) }
+ | texp ',' exp '..' { sLL $1 $> $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) }
+ | texp '..' exp { sLL $1 $> $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) }
+ | texp ',' exp '..' exp { sLL $1 $> $ ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5) }
| texp '|' flattenedpquals
{% checkMonadComp >>= \ ctxt ->
return (sL (comb2 $1 $>) $
mkHsComp ctxt (unLoc $3) $1) }
lexps :: { Located [LHsExpr RdrName] }
- : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) }
- | texp ',' texp { LL [$3,$1] }
+ : lexps ',' texp { sLL $1 $> (((:) $! $3) $! unLoc $1) }
+ | texp ',' texp { sLL $1 $> [$3,$1] }
-----------------------------------------------------------------------------
-- List Comprehensions
flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }
: pquals { case (unLoc $1) of
- [qs] -> L1 qs
+ [qs] -> sL1 $1 qs
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
- qss -> L1 [L1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |
+ qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |
qs <- qss]
noSyntaxExpr noSyntaxExpr]
-- We actually found some actual parallel lists so
@@ -1763,12 +1769,12 @@ pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] }
squals :: { Located [LStmt RdrName (LHsExpr 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] }
+ : squals ',' transformqual { sLL $1 $> [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] }
+ | squals ',' qual { sLL $1 $> ($3 : unLoc $1) }
+ | transformqual { sLL $1 $> [L (getLoc $1) ((unLoc $1) [])] }
+ | qual { sL1 $1 [$1] }
+-- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) }
+-- | '{|' pquals '|}' { sL1 $1 [$2] }
-- It is possible to enable bracketing (associating) qualifier lists
@@ -1778,10 +1784,10 @@ squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, b
transformqual :: { Located ([LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (LHsExpr RdrName)) }
-- Function is applied to a list of stmts *in order*
- : 'then' exp { LL $ \ss -> (mkTransformStmt ss $2) }
- | 'then' exp 'by' exp { LL $ \ss -> (mkTransformByStmt ss $2 $4) }
- | 'then' 'group' 'using' exp { LL $ \ss -> (mkGroupUsingStmt ss $4) }
- | 'then' 'group' 'by' exp 'using' exp { LL $ \ss -> (mkGroupByUsingStmt ss $4 $6) }
+ : 'then' exp { sLL $1 $> $ \ss -> (mkTransformStmt ss $2) }
+ | 'then' exp 'by' exp { sLL $1 $> $ \ss -> (mkTransformByStmt ss $2 $4) }
+ | 'then' 'group' 'using' exp { sLL $1 $> $ \ss -> (mkGroupUsingStmt ss $4) }
+ | 'then' 'group' 'by' exp 'using' exp { sLL $1 $> $ \ss -> (mkGroupByUsingStmt ss $4 $6) }
-- Note that 'group' is a special_id, which means that you can enable
-- TransformListComp while still using Data.List.group. However, this
@@ -1798,12 +1804,12 @@ transformqual :: { Located ([LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (L
parr :: { LHsExpr RdrName }
: { noLoc (ExplicitPArr placeHolderType []) }
- | texp { L1 $ ExplicitPArr placeHolderType [$1] }
- | lexps { L1 $ ExplicitPArr placeHolderType
+ | texp { sL1 $1 $ ExplicitPArr placeHolderType [$1] }
+ | lexps { sL1 $1 $ ExplicitPArr placeHolderType
(reverse (unLoc $1)) }
- | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
- | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 }
+ | texp '..' exp { sLL $1 $> $ PArrSeq noPostTcExpr (FromTo $1 $3) }
+ | texp ',' exp '..' exp { sLL $1 $> $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+ | texp '|' flattenedpquals { sLL $1 $> $ mkHsComp PArrComp (unLoc $3) $1 }
-- We are reusing `lexps' and `flattenedpquals' from the list case.
@@ -1814,52 +1820,52 @@ guardquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }
: guardquals1 { L (getLoc $1) (reverse (unLoc $1)) }
guardquals1 :: { Located [LStmt RdrName (LHsExpr RdrName)] }
- : guardquals1 ',' qual { LL ($3 : unLoc $1) }
- | qual { L1 [$1] }
+ : guardquals1 ',' qual { sLL $1 $> ($3 : unLoc $1) }
+ | qual { sL1 $1 [$1] }
-----------------------------------------------------------------------------
-- Case alternatives
altslist :: { Located [LMatch RdrName (LHsExpr RdrName)] }
- : '{' alts '}' { LL (reverse (unLoc $2)) }
+ : '{' alts '}' { sLL $1 $> (reverse (unLoc $2)) }
| vocurly alts close { L (getLoc $2) (reverse (unLoc $2)) }
| '{' '}' { noLoc [] }
| vocurly close { noLoc [] }
alts :: { Located [LMatch RdrName (LHsExpr RdrName)] }
- : alts1 { L1 (unLoc $1) }
- | ';' alts { LL (unLoc $2) }
+ : alts1 { sL1 $1 (unLoc $1) }
+ | ';' alts { sLL $1 $> (unLoc $2) }
alts1 :: { Located [LMatch RdrName (LHsExpr RdrName)] }
- : alts1 ';' alt { LL ($3 : unLoc $1) }
- | alts1 ';' { LL (unLoc $1) }
- | alt { L1 [$1] }
+ : alts1 ';' alt { sLL $1 $> ($3 : unLoc $1) }
+ | alts1 ';' { sLL $1 $> (unLoc $1) }
+ | alt { sL1 $1 [$1] }
alt :: { LMatch RdrName (LHsExpr RdrName) }
- : pat opt_sig alt_rhs { LL (Match [$1] $2 (unLoc $3)) }
+ : pat opt_sig alt_rhs { sLL $1 $> (Match [$1] $2 (unLoc $3)) }
alt_rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) }
- : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)) }
+ : ralt wherebinds { sLL $1 $> (GRHSs (unLoc $1) (unLoc $2)) }
ralt :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
- : '->' exp { LL (unguardedRHS $2) }
- | gdpats { L1 (reverse (unLoc $1)) }
+ : '->' exp { sLL $1 $> (unguardedRHS $2) }
+ | gdpats { sL1 $1 (reverse (unLoc $1)) }
gdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
- : gdpats gdpat { LL ($2 : unLoc $1) }
- | gdpat { L1 [$1] }
+ : gdpats gdpat { sLL $1 $> ($2 : unLoc $1) }
+ | gdpat { sL1 $1 [$1] }
-- optional semi-colons between the guards of a MultiWayIf, because we use
-- layout here, but we don't need (or want) the semicolon as a separator (#7783).
gdpatssemi :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
: gdpatssemi gdpat optSemi { sL (comb2 $1 $2) ($2 : unLoc $1) }
- | gdpat optSemi { L1 [$1] }
+ | gdpat optSemi { sL1 $1 [$1] }
-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to
-- generate the open brace in addition to the vertical bar in the lexer, and
-- we don't need it.
ifgdpats :: { Located [LGRHS RdrName (LHsExpr RdrName)] }
- : '{' gdpatssemi '}' { LL (unLoc $2) }
+ : '{' gdpatssemi '}' { sLL $1 $> (unLoc $2) }
| gdpatssemi close { $1 }
gdpat :: { LGRHS RdrName (LHsExpr RdrName) }
@@ -1871,15 +1877,15 @@ gdpat :: { LGRHS RdrName (LHsExpr RdrName) }
-- we parse them right when bang-patterns are off
pat :: { LPat RdrName }
pat : exp {% checkPattern empty $1 }
- | '!' aexp {% checkPattern empty (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+ | '!' aexp {% checkPattern empty (sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2)) }
bindpat :: { LPat RdrName }
bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 }
- | '!' aexp {% checkPattern (text "Possibly caused by a missing 'do'?") (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+ | '!' aexp {% checkPattern (text "Possibly caused by a missing 'do'?") (sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2)) }
apat :: { LPat RdrName }
apat : aexp {% checkPattern empty $1 }
- | '!' aexp {% checkPattern empty (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+ | '!' aexp {% checkPattern empty (sLL $1 $> (SectionR (sL1 $1 (HsVar bang_RDR)) $2)) }
apats :: { [LPat RdrName] }
: apat apats { $1 : $2 }
@@ -1889,7 +1895,7 @@ apats :: { [LPat RdrName] }
-- Statement sequences
stmtlist :: { Located [LStmt RdrName (LHsExpr RdrName)] }
- : '{' stmts '}' { LL (unLoc $2) }
+ : '{' stmts '}' { sLL $1 $> (unLoc $2) }
| vocurly stmts close { $2 }
-- do { ;; s ; s ; ; s ;; }
@@ -1898,12 +1904,12 @@ stmtlist :: { Located [LStmt RdrName (LHsExpr RdrName)] }
-- So we use BodyStmts throughout, and switch the last one over
-- in ParseUtils.checkDo instead
stmts :: { Located [LStmt RdrName (LHsExpr RdrName)] }
- : stmt stmts_help { LL ($1 : unLoc $2) }
- | ';' stmts { LL (unLoc $2) }
+ : stmt stmts_help { sLL $1 $> ($1 : unLoc $2) }
+ | ';' stmts { sLL $1 $> (unLoc $2) }
| {- empty -} { noLoc [] }
stmts_help :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- might be empty
- : ';' stmts { LL (unLoc $2) }
+ : ';' stmts { sLL $1 $> (unLoc $2) }
| {- empty -} { noLoc [] }
-- For typing stmts at the GHCi prompt, where
@@ -1914,12 +1920,12 @@ maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) }
stmt :: { LStmt RdrName (LHsExpr RdrName) }
: qual { $1 }
- | 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) }
+ | 'rec' stmtlist { sLL $1 $> $ mkRecStmt (unLoc $2) }
qual :: { LStmt RdrName (LHsExpr RdrName) }
- : bindpat '<-' exp { LL $ mkBindStmt $1 $3 }
- | exp { L1 $ mkBodyStmt $1 }
- | 'let' binds { LL $ LetStmt (unLoc $2) }
+ : bindpat '<-' exp { sLL $1 $> $ mkBindStmt $1 $3 }
+ | exp { sL1 $1 $ mkBodyStmt $1 }
+ | 'let' binds { sLL $1 $> $ LetStmt (unLoc $2) }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
@@ -1948,16 +1954,16 @@ fbind :: { HsRecField RdrName (LHsExpr RdrName) }
dbinds :: { Located [LIPBind RdrName] }
: dbinds ';' dbind { let { this = $3; rest = unLoc $1 }
- in rest `seq` this `seq` LL (this : rest) }
- | dbinds ';' { LL (unLoc $1) }
- | dbind { let this = $1 in this `seq` L1 [this] }
+ in rest `seq` this `seq` sLL $1 $> (this : rest) }
+ | dbinds ';' { sLL $1 $> (unLoc $1) }
+ | dbind { let this = $1 in this `seq` sL1 $1 [this] }
-- | {- empty -} { [] }
dbind :: { LIPBind RdrName }
-dbind : ipvar '=' exp { LL (IPBind (Left (unLoc $1)) $3) }
+dbind : ipvar '=' exp { sLL $1 $> (IPBind (Left (unLoc $1)) $3) }
ipvar :: { Located HsIPName }
- : IPDUPVARID { L1 (HsIPName (getIPDUPVARID $1)) }
+ : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
-----------------------------------------------------------------------------
-- Warnings and deprecations
@@ -1979,8 +1985,8 @@ name_boolformula_atom :: { BooleanFormula (Located RdrName) }
| name_var { mkVar $1 }
namelist :: { Located [RdrName] }
-namelist : name_var { L1 [unLoc $1] }
- | name_var ',' namelist { LL (unLoc $1 : unLoc $3) }
+namelist : name_var { sL1 $1 [unLoc $1] }
+ | name_var ',' namelist { sLL $1 $> (unLoc $1 : unLoc $3) }
name_var :: { Located RdrName }
name_var : var { $1 }
@@ -1990,33 +1996,33 @@ name_var : var { $1 }
-- Data constructors
qcon :: { Located RdrName }
: qconid { $1 }
- | '(' qconsym ')' { LL (unLoc $2) }
- | sysdcon { L1 $ nameRdrName (dataConName (unLoc $1)) }
+ | '(' qconsym ')' { sLL $1 $> (unLoc $2) }
+ | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
-- The case of '[:' ':]' is part of the production `parr'
con :: { Located RdrName }
: conid { $1 }
- | '(' consym ')' { LL (unLoc $2) }
- | sysdcon { L1 $ nameRdrName (dataConName (unLoc $1)) }
+ | '(' consym ')' { sLL $1 $> (unLoc $2) }
+ | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }
con_list :: { Located [Located RdrName] }
-con_list : con { L1 [$1] }
- | con ',' con_list { LL ($1 : unLoc $3) }
+con_list : con { sL1 $1 [$1] }
+ | con ',' con_list { sLL $1 $> ($1 : unLoc $3) }
sysdcon :: { Located DataCon } -- Wired in data constructors
- : '(' ')' { LL unitDataCon }
- | '(' commas ')' { LL $ tupleCon BoxedTuple ($2 + 1) }
- | '(#' '#)' { LL $ unboxedUnitDataCon }
- | '(#' commas '#)' { LL $ tupleCon UnboxedTuple ($2 + 1) }
- | '[' ']' { LL nilDataCon }
+ : '(' ')' { sLL $1 $> unitDataCon }
+ | '(' commas ')' { sLL $1 $> $ tupleCon BoxedTuple ($2 + 1) }
+ | '(#' '#)' { sLL $1 $> $ unboxedUnitDataCon }
+ | '(#' commas '#)' { sLL $1 $> $ tupleCon UnboxedTuple ($2 + 1) }
+ | '[' ']' { sLL $1 $> nilDataCon }
conop :: { Located RdrName }
: consym { $1 }
- | '`' conid '`' { LL (unLoc $2) }
+ | '`' conid '`' { sLL $1 $> (unLoc $2) }
qconop :: { Located RdrName }
: qconsym { $1 }
- | '`' qconid '`' { LL (unLoc $2) }
+ | '`' qconid '`' { sLL $1 $> (unLoc $2) }
----------------------------------------------------------------------------
-- Type constructors
@@ -2026,48 +2032,48 @@ qconop :: { Located RdrName }
-- between gtycon and ntgtycon
gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples
: ntgtycon { $1 }
- | '(' ')' { LL $ getRdrName unitTyCon }
- | '(#' '#)' { LL $ getRdrName unboxedUnitTyCon }
+ | '(' ')' { sLL $1 $> $ getRdrName unitTyCon }
+ | '(#' '#)' { sLL $1 $> $ getRdrName unboxedUnitTyCon }
ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples
: oqtycon { $1 }
- | '(' commas ')' { LL $ getRdrName (tupleTyCon BoxedTuple ($2 + 1)) }
- | '(#' commas '#)' { LL $ getRdrName (tupleTyCon UnboxedTuple ($2 + 1)) }
- | '(' '->' ')' { LL $ getRdrName funTyCon }
- | '[' ']' { LL $ listTyCon_RDR }
- | '[:' ':]' { LL $ parrTyCon_RDR }
- | '(' '~#' ')' { LL $ getRdrName eqPrimTyCon }
+ | '(' commas ')' { sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple ($2 + 1)) }
+ | '(#' commas '#)' { sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple ($2 + 1)) }
+ | '(' '->' ')' { sLL $1 $> $ getRdrName funTyCon }
+ | '[' ']' { sLL $1 $> $ listTyCon_RDR }
+ | '[:' ':]' { sLL $1 $> $ parrTyCon_RDR }
+ | '(' '~#' ')' { sLL $1 $> $ getRdrName eqPrimTyCon }
oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon;
-- These can appear in export lists
: qtycon { $1 }
- | '(' qtyconsym ')' { LL (unLoc $2) }
- | '(' '~' ')' { LL $ eqTyCon_RDR }
+ | '(' qtyconsym ')' { sLL $1 $> (unLoc $2) }
+ | '(' '~' ')' { sLL $1 $> $ eqTyCon_RDR }
qtyconop :: { Located RdrName } -- Qualified or unqualified
: qtyconsym { $1 }
- | '`' qtycon '`' { LL (unLoc $2) }
+ | '`' qtycon '`' { sLL $1 $> (unLoc $2) }
qtycon :: { Located RdrName } -- Qualified or unqualified
- : QCONID { L1 $! mkQual tcClsName (getQCONID $1) }
- | PREFIXQCONSYM { L1 $! mkQual tcClsName (getPREFIXQCONSYM $1) }
+ : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) }
+ | PREFIXQCONSYM { sL1 $1 $! mkQual tcClsName (getPREFIXQCONSYM $1) }
| tycon { $1 }
tycon :: { Located RdrName } -- Unqualified
- : CONID { L1 $! mkUnqual tcClsName (getCONID $1) }
+ : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }
qtyconsym :: { Located RdrName }
- : QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) }
- | QVARSYM { L1 $! mkQual tcClsName (getQVARSYM $1) }
+ : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) }
+ | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) }
| tyconsym { $1 }
-- Does not include "!", because that is used for strictness marks
-- or ".", because that separates the quantified type vars from the rest
tyconsym :: { Located RdrName }
- : CONSYM { L1 $! mkUnqual tcClsName (getCONSYM $1) }
- | VARSYM { L1 $! mkUnqual tcClsName (getVARSYM $1) }
- | '*' { L1 $! mkUnqual tcClsName (fsLit "*") }
- | '-' { L1 $! mkUnqual tcClsName (fsLit "-") }
+ : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
+ | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }
+ | '*' { sL1 $1 $! mkUnqual tcClsName (fsLit "*") }
+ | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
-----------------------------------------------------------------------------
@@ -2079,23 +2085,23 @@ op :: { Located RdrName } -- used in infix decls
varop :: { Located RdrName }
: varsym { $1 }
- | '`' varid '`' { LL (unLoc $2) }
+ | '`' varid '`' { sLL $1 $> (unLoc $2) }
qop :: { LHsExpr RdrName } -- used in sections
- : qvarop { L1 $ HsVar (unLoc $1) }
- | qconop { L1 $ HsVar (unLoc $1) }
+ : qvarop { sL1 $1 $ HsVar (unLoc $1) }
+ | qconop { sL1 $1 $ HsVar (unLoc $1) }
qopm :: { LHsExpr RdrName } -- used in sections
- : qvaropm { L1 $ HsVar (unLoc $1) }
- | qconop { L1 $ HsVar (unLoc $1) }
+ : qvaropm { sL1 $1 $ HsVar (unLoc $1) }
+ | qconop { sL1 $1 $ HsVar (unLoc $1) }
qvarop :: { Located RdrName }
: qvarsym { $1 }
- | '`' qvarid '`' { LL (unLoc $2) }
+ | '`' qvarid '`' { sLL $1 $> (unLoc $2) }
qvaropm :: { Located RdrName }
: qvarsym_no_minus { $1 }
- | '`' qvarid '`' { LL (unLoc $2) }
+ | '`' qvarid '`' { sLL $1 $> (unLoc $2) }
-----------------------------------------------------------------------------
-- Type variables
@@ -2104,7 +2110,7 @@ tyvar :: { Located RdrName }
tyvar : tyvarid { $1 }
tyvarop :: { Located RdrName }
-tyvarop : '`' tyvarid '`' { LL (unLoc $2) }
+tyvarop : '`' tyvarid '`' { sLL $1 $> (unLoc $2) }
| '.' {% parseErrorSDoc (getLoc $1)
(vcat [ptext (sLit "Illegal symbol '.' in type"),
ptext (sLit "Perhaps you intended to use RankNTypes or a similar language"),
@@ -2112,44 +2118,44 @@ tyvarop : '`' tyvarid '`' { LL (unLoc $2) }
}
tyvarid :: { Located RdrName }
- : VARID { L1 $! mkUnqual tvName (getVARID $1) }
- | special_id { L1 $! mkUnqual tvName (unLoc $1) }
- | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") }
- | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") }
- | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") }
+ : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) }
+ | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) }
+ | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") }
+ | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") }
+ | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") }
-----------------------------------------------------------------------------
-- Variables
var :: { Located RdrName }
: varid { $1 }
- | '(' varsym ')' { LL (unLoc $2) }
+ | '(' varsym ')' { sLL $1 $> (unLoc $2) }
qvar :: { Located RdrName }
: qvarid { $1 }
- | '(' varsym ')' { LL (unLoc $2) }
- | '(' qvarsym1 ')' { LL (unLoc $2) }
+ | '(' varsym ')' { sLL $1 $> (unLoc $2) }
+ | '(' qvarsym1 ')' { sLL $1 $> (unLoc $2) }
-- We've inlined qvarsym here so that the decision about
-- whether it's a qvar or a var can be postponed until
-- *after* we see the close paren.
qvarid :: { Located RdrName }
: varid { $1 }
- | QVARID { L1 $! mkQual varName (getQVARID $1) }
- | PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
+ | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) }
+ | PREFIXQVARSYM { sL1 $1 $! mkQual varName (getPREFIXQVARSYM $1) }
-- Note that 'role' and 'family' get lexed separately regardless of
-- the use of extensions. However, because they are listed here, this
-- is OK and they can be used as normal varids.
varid :: { Located RdrName }
- : VARID { L1 $! mkUnqual varName (getVARID $1) }
- | special_id { L1 $! mkUnqual varName (unLoc $1) }
- | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") }
- | 'safe' { L1 $! mkUnqual varName (fsLit "safe") }
- | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") }
- | 'forall' { L1 $! mkUnqual varName (fsLit "forall") }
- | 'family' { L1 $! mkUnqual varName (fsLit "family") }
- | 'role' { L1 $! mkUnqual varName (fsLit "role") }
+ : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) }
+ | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) }
+ | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") }
+ | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") }
+ | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible") }
+ | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") }
+ | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") }
+ | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") }
qvarsym :: { Located RdrName }
: varsym { $1 }
@@ -2160,15 +2166,15 @@ qvarsym_no_minus :: { Located RdrName }
| qvarsym1 { $1 }
qvarsym1 :: { Located RdrName }
-qvarsym1 : QVARSYM { L1 $ mkQual varName (getQVARSYM $1) }
+qvarsym1 : QVARSYM { sL1 $1 $ mkQual varName (getQVARSYM $1) }
varsym :: { Located RdrName }
: varsym_no_minus { $1 }
- | '-' { L1 $ mkUnqual varName (fsLit "-") }
+ | '-' { sL1 $1 $ mkUnqual varName (fsLit "-") }
varsym_no_minus :: { Located RdrName } -- varsym not including '-'
- : VARSYM { L1 $ mkUnqual varName (getVARSYM $1) }
- | special_sym { L1 $ mkUnqual varName (unLoc $1) }
+ : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) }
+ | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) }
-- These special_ids are treated as keywords in various places,
@@ -2177,58 +2183,58 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
-- whose treatment differs depending on context
special_id :: { Located FastString }
special_id
- : 'as' { L1 (fsLit "as") }
- | 'qualified' { L1 (fsLit "qualified") }
- | 'hiding' { L1 (fsLit "hiding") }
- | 'export' { L1 (fsLit "export") }
- | 'label' { L1 (fsLit "label") }
- | 'dynamic' { L1 (fsLit "dynamic") }
- | 'stdcall' { L1 (fsLit "stdcall") }
- | 'ccall' { L1 (fsLit "ccall") }
- | 'capi' { L1 (fsLit "capi") }
- | 'prim' { L1 (fsLit "prim") }
- | 'javascript' { L1 (fsLit "javascript") }
- | 'group' { L1 (fsLit "group") }
+ : 'as' { sL1 $1 (fsLit "as") }
+ | 'qualified' { sL1 $1 (fsLit "qualified") }
+ | 'hiding' { sL1 $1 (fsLit "hiding") }
+ | 'export' { sL1 $1 (fsLit "export") }
+ | 'label' { sL1 $1 (fsLit "label") }
+ | 'dynamic' { sL1 $1 (fsLit "dynamic") }
+ | 'stdcall' { sL1 $1 (fsLit "stdcall") }
+ | 'ccall' { sL1 $1 (fsLit "ccall") }
+ | 'capi' { sL1 $1 (fsLit "capi") }
+ | 'prim' { sL1 $1 (fsLit "prim") }
+ | 'javascript' { sL1 $1 (fsLit "javascript") }
+ | 'group' { sL1 $1 (fsLit "group") }
special_sym :: { Located FastString }
-special_sym : '!' { L1 (fsLit "!") }
- | '.' { L1 (fsLit ".") }
- | '*' { L1 (fsLit "*") }
+special_sym : '!' { sL1 $1 (fsLit "!") }
+ | '.' { sL1 $1 (fsLit ".") }
+ | '*' { sL1 $1 (fsLit "*") }
-----------------------------------------------------------------------------
-- Data constructors
qconid :: { Located RdrName } -- Qualified or unqualified
: conid { $1 }
- | QCONID { L1 $! mkQual dataName (getQCONID $1) }
- | PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) }
+ | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) }
+ | PREFIXQCONSYM { sL1 $1 $! mkQual dataName (getPREFIXQCONSYM $1) }
conid :: { Located RdrName }
- : CONID { L1 $ mkUnqual dataName (getCONID $1) }
+ : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) }
qconsym :: { Located RdrName } -- Qualified or unqualified
: consym { $1 }
- | QCONSYM { L1 $ mkQual dataName (getQCONSYM $1) }
+ | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) }
consym :: { Located RdrName }
- : CONSYM { L1 $ mkUnqual dataName (getCONSYM $1) }
+ : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) }
-- ':' means only list cons
- | ':' { L1 $ consDataCon_RDR }
+ | ':' { sL1 $1 $ consDataCon_RDR }
-----------------------------------------------------------------------------
-- Literals
literal :: { Located HsLit }
- : CHAR { L1 $ HsChar $ getCHAR $1 }
- | STRING { L1 $ HsString $ getSTRING $1 }
- | PRIMINTEGER { L1 $ HsIntPrim $ getPRIMINTEGER $1 }
- | PRIMWORD { L1 $ HsWordPrim $ getPRIMWORD $1 }
- | PRIMCHAR { L1 $ HsCharPrim $ getPRIMCHAR $1 }
- | PRIMSTRING { L1 $ HsStringPrim $ getPRIMSTRING $1 }
- | PRIMFLOAT { L1 $ HsFloatPrim $ getPRIMFLOAT $1 }
- | PRIMDOUBLE { L1 $ HsDoublePrim $ getPRIMDOUBLE $1 }
+ : CHAR { sL1 $1 $ HsChar $ getCHAR $1 }
+ | STRING { sL1 $1 $ HsString $ getSTRING $1 }
+ | PRIMINTEGER { sL1 $1 $ HsIntPrim $ getPRIMINTEGER $1 }
+ | PRIMWORD { sL1 $1 $ HsWordPrim $ getPRIMWORD $1 }
+ | PRIMCHAR { sL1 $1 $ HsCharPrim $ getPRIMCHAR $1 }
+ | PRIMSTRING { sL1 $1 $ HsStringPrim $ getPRIMSTRING $1 }
+ | PRIMFLOAT { sL1 $1 $ HsFloatPrim $ getPRIMFLOAT $1 }
+ | PRIMDOUBLE { sL1 $1 $ HsDoublePrim $ getPRIMDOUBLE $1 }
-----------------------------------------------------------------------------
-- Layout
@@ -2241,8 +2247,8 @@ close :: { () }
-- Miscellaneous (mostly renamings)
modid :: { Located ModuleName }
- : CONID { L1 $ mkModuleNameFS (getCONID $1) }
- | QCONID { L1 $ let (mod,c) = getQCONID $1 in
+ : CONID { sL1 $1 $ mkModuleNameFS (getCONID $1) }
+ | QCONID { sL1 $1 $ let (mod,c) = getQCONID $1 in
mkModuleNameFS
(mkFastString
(unpackFS mod ++ '.':unpackFS c))
@@ -2256,24 +2262,24 @@ commas :: { Int } -- One or more commas
-- Documentation comments
docnext :: { LHsDocString }
- : DOCNEXT {% return (L1 (HsDocString (mkFastString (getDOCNEXT $1)))) }
+ : DOCNEXT {% return (sL1 $1 (HsDocString (mkFastString (getDOCNEXT $1)))) }
docprev :: { LHsDocString }
- : DOCPREV {% return (L1 (HsDocString (mkFastString (getDOCPREV $1)))) }
+ : DOCPREV {% return (sL1 $1 (HsDocString (mkFastString (getDOCPREV $1)))) }
docnamed :: { Located (String, HsDocString) }
: DOCNAMED {%
let string = getDOCNAMED $1
(name, rest) = break isSpace string
- in return (L1 (name, HsDocString (mkFastString rest))) }
+ in return (sL1 $1 (name, HsDocString (mkFastString rest))) }
docsection :: { Located (Int, HsDocString) }
: DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
- return (L1 (n, HsDocString (mkFastString doc))) }
+ return (sL1 $1 (n, HsDocString (mkFastString doc))) }
moduleheader :: { Maybe LHsDocString }
: DOCNEXT {% let string = getDOCNEXT $1 in
- return (Just (L1 (HsDocString (mkFastString string)))) }
+ return (Just (sL1 $1 (HsDocString (mkFastString string)))) }
maybe_docprev :: { Maybe LHsDocString }
: docprev { Just $1 }
@@ -2345,6 +2351,16 @@ comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
sL :: SrcSpan -> a -> Located a
sL span a = span `seq` a `seq` L span a
+-- replaced last 3 CPP macros in this file
+{-# INLINE sL0 #-}
+sL0 = L noSrcSpan -- #define L0 L noSrcSpan
+
+{-# INLINE sL1 #-}
+sL1 x = sL (getLoc x) -- #define L1 sL (getLoc $1)
+
+{-# INLINE sLL #-}
+sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
+
-- Make a source location for the file. We're a bit lazy here and just
-- make a point SrcSpan at line 1, column 0. Strictly speaking we should
-- try to find the span of the whole file (ToDo).
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.hs
index e6969e7422..625c4dc6e9 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1,9 +1,9 @@
-o%
-% (c) The University of Glasgow, 1996-2003
+--
+-- (c) The University of Glasgow 2002-2006
+--
-Functions over HsSyn specialised to RdrName.
+-- Functions over HsSyn specialised to RdrName.
-\begin{code}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -12,11 +12,11 @@ module RdrHsSyn (
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
- mkClassDecl,
- mkTyData, mkDataFamInst,
+ mkClassDecl,
+ mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
- mkTyFamInst,
- mkFamDecl,
+ mkTyFamInst,
+ mkFamDecl,
splitCon, mkInlinePragma,
splitPatSyn, toPatSynMatchGroup,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
@@ -62,7 +62,7 @@ module RdrHsSyn (
import HsSyn -- Lots of it
import Class ( FunDep )
import CoAxiom ( Role, fsFromRole )
-import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
+import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace,
rdrNameSpace )
import OccName ( tcClsName, isVarNameSpace )
@@ -94,26 +94,24 @@ import Data.Char
import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
#include "HsVersions.h"
-\end{code}
-%************************************************************************
-%* *
-\subsection{Construction functions for Rdr stuff}
-%* *
-%************************************************************************
+{- **********************************************************************
+
+ Construction functions for Rdr stuff
-mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
-by deriving them from the name of the class. We fill in the names for the
-tycon and datacon corresponding to the class, by deriving them from the
-name of the class itself. This saves recording the names in the interface
-file (which would be equally good).
+ ********************************************************************* -}
-Similarly for mkConDecl, mkClassOpSig and default-method names.
+-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and
+-- datacon by deriving them from the name of the class. We fill in the names
+-- for the tycon and datacon corresponding to the class, by deriving them
+-- from the name of the class itself. This saves recording the names in the
+-- interface file (which would be equally good).
- *** See "THE NAMING STORY" in HsDecls ****
+-- Similarly for mkConDecl, mkClassOpSig and default-method names.
+
+-- *** See "THE NAMING STORY" in HsDecls ****
-\begin{code}
mkTyClD :: LTyClDecl n -> LHsDecl n
mkTyClD (L loc d) = L loc (TyClD d)
@@ -142,8 +140,8 @@ mkATDefault :: LTyFamInstDecl RdrName
-- Take a type-family instance declaration and turn it into
-- a type-family default equation for a class declaration
-- We parse things as the former and use this function to convert to the latter
---
--- We use the Either monad because this also called
+--
+-- We use the Either monad because this also called
-- from Convert.hs
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
| TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
@@ -179,7 +177,7 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
= do { checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt
; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
- , dd_ctxt = cxt
+ , dd_ctxt = cxt
, dd_cons = data_cons
, dd_kindSig = ksig
, dd_derivs = maybe_deriv }) }
@@ -283,20 +281,18 @@ mkRoleAnnotDecl loc tycon roles
-- will this last case ever happen??
suggestions list = hang (text "Perhaps you meant one of these:")
2 (pprWithCommas (quotes . ppr) list)
-\end{code}
-%************************************************************************
-%* *
-\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
-%* *
-%************************************************************************
+{- **********************************************************************
+
+ #cvBinds-etc# Converting to @HsBinds@, etc.
-Function definitions are restructured here. Each is assumed to be recursive
-initially, and non recursive definitions are discovered by the dependency
-analyser.
+ ********************************************************************* -}
+
+-- | Function definitions are restructured here. Each is assumed to be recursive
+-- initially, and non recursive definitions are discovered by the dependency
+-- analyser.
-\begin{code}
-- | Groups together bindings for a single function
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
@@ -311,7 +307,7 @@ cvTopDecls decls = go (fromOL decls)
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
= case cvBindsAndSigs binding of
- (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _)
+ (mbs, sigs, fam_ds, tfam_insts, dfam_insts, _)
-> ASSERT( null fam_ds && null tfam_insts && null dfam_insts)
ValBindsIn mbs sigs
@@ -384,16 +380,13 @@ has_args ((L _ (Match args _ _)) : _) = not (null args)
-- no arguments. This is necessary now that variable bindings
-- with no arguments are now treated as FunBinds rather
-- than pattern bindings (tests/rename/should_fail/rnfail002).
-\end{code}
-%************************************************************************
-%* *
-\subsection[PrefixToHS-utils]{Utilities for conversion}
-%* *
-%************************************************************************
+{- **********************************************************************
+
+ #PrefixToHS-utils# Utilities for conversion
+ ********************************************************************* -}
-\begin{code}
-----------------------------------------------------------------------------
-- splitCon
@@ -541,57 +534,55 @@ tyConToDataCon loc tc
extra | tc == forall_tv_RDR
= text "Perhaps you intended to use ExistentialQuantification"
| otherwise = empty
-\end{code}
-
-Note [Sorting out the result type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a GADT declaration which is not a record, we put the whole constr
-type into the ResTyGADT for now; the renamer will unravel it once it
-has sorted out operator fixities. Consider for example
- C :: a :*: b -> a :*: b -> a :+: b
-Initially this type will parse as
- a :*: (b -> (a :*: (b -> (a :+: b))))
-
-so it's hard to split up the arguments until we've done the precedence
-resolution (in the renamer) On the other hand, for a record
- { x,y :: Int } -> a :*: b
-there is no doubt. AND we need to sort records out so that
-we can bring x,y into scope. So:
- * For PrefixCon we keep all the args in the ResTyGADT
- * For RecCon we do not
-
-\begin{code}
+
+-- | Note [Sorting out the result type]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In a GADT declaration which is not a record, we put the whole constr
+-- type into the ResTyGADT for now; the renamer will unravel it once it
+-- has sorted out operator fixities. Consider for example
+-- C :: a :*: b -> a :*: b -> a :+: b
+-- Initially this type will parse as
+-- a :*: (b -> (a :*: (b -> (a :+: b))))
+
+-- so it's hard to split up the arguments until we've done the precedence
+-- resolution (in the renamer) On the other hand, for a record
+-- { x,y :: Int } -> a :*: b
+-- there is no doubt. AND we need to sort records out so that
+-- we can bring x,y into scope. So:
+-- * For PrefixCon we keep all the args in the ResTyGADT
+-- * For RecCon we do not
+
checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
-- Same as checkTyVars, but in the P monad
-checkTyVarsP pp_what equals_or_where tc tparms
- = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
+checkTyVarsP pp_what equals_or_where tc tparms
+ = eitherToP $ checkTyVars pp_what equals_or_where tc tparms
eitherToP :: Either (SrcSpan, SDoc) a -> P a
-- Adapts the Either monad to the P monad
eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
eitherToP (Right thing) = return thing
-checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
+checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
-> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName)
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature)
-- We use the Either monad because it's also called (via mkATDefault) from
-- Convert.hs
-checkTyVars pp_what equals_or_where tc tparms
+checkTyVars pp_what equals_or_where tc tparms
= do { tvs <- mapM chk tparms
; return (mkHsQTvs tvs) }
where
-
+
-- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
| isRdrTyVar tv = return (L l (KindedTyVar tv k))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv))
chk t@(L loc _)
- = Left (loc,
+ = Left (loc,
vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
, ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc)
, vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form"))
- , nest 2 (pp_what <+> ppr tc
+ , nest 2 (pp_what <+> ppr tc
<+> hsep (map text (takeList tparms allNameStrings))
<+> equals_or_where) ] ])
@@ -630,7 +621,7 @@ checkTyClHdr ty
where
goL (L l ty) acc = go l ty acc
- go l (HsTyVar tc) acc
+ go l (HsTyVar tc) acc
| isRdrTc tc = return (L l tc, acc)
go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc
| isRdrTc tc = return (ltc, t1:t2:acc)
@@ -750,7 +741,7 @@ checkAPat msg loc e0 = do
RecordCon c _ (HsRecFields fs dd)
-> do fs <- mapM (checkPatField msg) fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
- HsSpliceE is_typed s | not is_typed
+ HsSpliceE is_typed s | not is_typed
-> return (SplicePat s)
HsQuasiQuoteE q -> return (QuasiQuotePat q)
_ -> patFail msg loc e0
@@ -873,10 +864,8 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>
text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>
text "else" <+> ppr elseExpr
-\end{code}
-\begin{code}
-- The parser left-associates, so there should
-- not be any OpApps inside the e's
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
@@ -968,25 +957,25 @@ locMap :: (SrcSpan -> a -> P b) -> Located a -> P (Located b)
locMap f (L l a) = f l a >>= (\b -> return $ L l b)
checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName)
-checkCmd _ (HsArrApp e1 e2 ptt haat b) =
+checkCmd _ (HsArrApp e1 e2 ptt haat b) =
return $ HsCmdArrApp e1 e2 ptt haat b
-checkCmd _ (HsArrForm e mf args) =
+checkCmd _ (HsArrForm e mf args) =
return $ HsCmdArrForm e mf args
-checkCmd _ (HsApp e1 e2) =
+checkCmd _ (HsApp e1 e2) =
checkCommand e1 >>= (\c -> return $ HsCmdApp c e2)
-checkCmd _ (HsLam mg) =
+checkCmd _ (HsLam mg) =
checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdLam mg')
-checkCmd _ (HsPar e) =
+checkCmd _ (HsPar e) =
checkCommand e >>= (\c -> return $ HsCmdPar c)
-checkCmd _ (HsCase e mg) =
+checkCmd _ (HsCase e mg) =
checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
checkCmd _ (HsIf cf ep et ee) = do
pt <- checkCommand et
pe <- checkCommand ee
return $ HsCmdIf cf ep pt pe
-checkCmd _ (HsLet lb e) =
+checkCmd _ (HsLet lb e) =
checkCommand e >>= (\c -> return $ HsCmdLet lb c)
-checkCmd _ (HsDo DoExpr stmts ty) =
+checkCmd _ (HsDo DoExpr stmts ty) =
mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty)
checkCmd _ (OpApp eLeft op _fixity eRight) = do
@@ -1003,11 +992,11 @@ checkCmdLStmt :: ExprLStmt RdrName -> P (CmdLStmt RdrName)
checkCmdLStmt = locMap checkCmdStmt
checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName)
-checkCmdStmt _ (LastStmt e r) =
+checkCmdStmt _ (LastStmt e r) =
checkCommand e >>= (\c -> return $ LastStmt c r)
-checkCmdStmt _ (BindStmt pat e b f) =
+checkCmdStmt _ (BindStmt pat e b f) =
checkCommand e >>= (\c -> return $ BindStmt pat c b f)
-checkCmdStmt _ (BodyStmt e t g ty) =
+checkCmdStmt _ (BodyStmt e t g ty) =
checkCommand e >>= (\c -> return $ BodyStmt c t g ty)
checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds
checkCmdStmt _ stmt@(RecStmt { recS_stmts = stmts }) = do
@@ -1030,7 +1019,7 @@ checkCmdGRHSs (GRHSs grhss binds) = do
checkCmdGRHS :: LGRHS RdrName (LHsExpr RdrName) -> P (LGRHS RdrName (LHsCmd RdrName))
checkCmdGRHS = locMap $ const convert
- where
+ where
convert (GRHS stmts e) = do
c <- checkCommand e
-- cmdStmts <- mapM checkCmdLStmt stmts
@@ -1040,7 +1029,7 @@ checkCmdGRHS = locMap $ const convert
cmdFail :: SrcSpan -> HsExpr RdrName -> P a
cmdFail loc e = parseErrorSDoc loc (text "Parse error in command:" <+> ppr e)
cmdStmtFail :: SrcSpan -> Stmt RdrName (LHsExpr RdrName) -> P a
-cmdStmtFail loc e = parseErrorSDoc loc
+cmdStmtFail loc e = parseErrorSDoc loc
(text "Parse error in command statement:" <+> ppr e)
---------------------------------------------------------------------------
@@ -1058,7 +1047,7 @@ mkRecConstrOrUpdate
-> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
-> P (HsExpr RdrName)
-mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd)
+mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd)
| isRdrDataCon c
= return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp _ (fs,dd)
@@ -1069,7 +1058,7 @@ mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma
--- The (Maybe Activation) is because the user can omit
+-- The (Maybe Activation) is because the user can omit
-- the activation spec (and usually does)
mkInlinePragma (inl, match_info) mb_act
= InlinePragma { inl_inline = inl
@@ -1181,18 +1170,16 @@ mkExport cconv (L _ entity, v, ty) = return $
--
mkExtName :: RdrName -> CLabelString
mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))
-\end{code}
--------------------------------------------------------------------------------
-- Help with module system imports/exports
-\begin{code}
data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ]
mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName
mkModuleImpExp name subs =
case subs of
- ImpExpAbs
+ ImpExpAbs
| isVarNameSpace (rdrNameSpace name) -> IEVar name
| otherwise -> IEThingAbs nameT
ImpExpAll -> IEThingAll nameT
@@ -1208,12 +1195,9 @@ mkTypeImpExp name =
then return (fmap (`setRdrNameSpace` tcClsName) name)
else parseErrorSDoc (getLoc name)
(text "Illegal keyword 'type' (use ExplicitNamespaces to enable)")
-\end{code}
-----------------------------------------------------------------------------
-- Misc utils
-\begin{code}
parseErrorSDoc :: SrcSpan -> SDoc -> P a
parseErrorSDoc span s = failSpanMsgP span s
-\end{code}
diff --git a/ghc.mk b/ghc.mk
index b75049fb19..d6f1bef23f 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -359,7 +359,7 @@ endif
# Packages to build
# The lists of packages that we *actually* going to build in each stage:
#
-# $(PACKAGES_STAGE0)
+# $(PACKAGES_STAGE0)
# $(PACKAGES_STAGE1)
# $(PACKAGES_STAGE2)
#
@@ -630,7 +630,7 @@ BUILD_DIRS += includes
BUILD_DIRS += rts
ifneq "$(BINDIST)" "YES"
-BUILD_DIRS += bindisttest
+BUILD_DIRS += bindisttest
BUILD_DIRS += utils/genapply
endif
@@ -696,10 +696,10 @@ stage1_libs : $(ALL_STAGE1_LIBS)
# ----------------------------------------------
# Per-package compiler flags
-#
-# If you want to add per-package compiler flags, this
+#
+# If you want to add per-package compiler flags, this
# is the place to do it. Do it like this for package <pkg>
-#
+#
# libraries/<pkg>_dist-boot_HC_OPTS += -Wwarn
# libraries/<pkg>_dist-install_HC_OPTS += -Wwarn
@@ -1140,7 +1140,7 @@ sdist-ghc-prep :
$(call sdist_ghc_file,compiler,stage2,cmm,,CmmLex,x)
$(call sdist_ghc_file,compiler,stage2,cmm,,CmmParse,y)
$(call sdist_ghc_file,compiler,stage2,parser,,Lexer,x)
- $(call sdist_ghc_file,compiler,stage2,parser,,Parser,y.pp)
+ $(call sdist_ghc_file,compiler,stage2,parser,,Parser,y)
$(call sdist_ghc_file,utils/hpc,dist-install,,,HpcParser,y)
$(call sdist_ghc_file,utils/genprimopcode,dist,,,Lexer,x)
$(call sdist_ghc_file,utils/genprimopcode,dist,,,Parser,y)
@@ -1225,7 +1225,6 @@ CLEAN_FILES += includes/ghcautoconf.h
CLEAN_FILES += includes/ghcplatform.h
CLEAN_FILES += includes/ghcversion.h
CLEAN_FILES += utils/ghc-pkg/Version.hs
-CLEAN_FILES += compiler/parser/Parser.y
CLEAN_FILES += compiler/prelude/primops.txt
CLEAN_FILES += $(wildcard compiler/primop*incl)
View Lorry Controller Status