diff options
| author | Josh Meredith <joshmeredith2008@gmail.com> | 2019-12-04 23:39:28 +1100 |
|---|---|---|
| committer | Josh Meredith <joshmeredith2008@gmail.com> | 2019-12-04 23:39:28 +1100 |
| commit | a8435165b84c32fd2ebdd1281dd6ee077e07ad5a (patch) | |
| tree | 791936d014aeaa26174c2dcbef34c14f3329dd04 | |
| parent | 7805441b4d5e22eb63a501e1e40383d10380dc92 (diff) | |
| parent | f03a41d4bf9418ee028ecb51654c928b2da74edd (diff) | |
| download | haskell-wip/binary-readerT.tar.gz | |
Merge branch 'master' into wip/binary-readerTwip/binary-readerT
449 files changed, 3902 insertions, 3340 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 56c81ab963..0bf5b24898 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -2,7 +2,7 @@ variables: GIT_SSL_NO_VERIFY: "1" # Commit of ghc/ci-images repository from which to pull Docker images - DOCKER_REV: 8beb70e553e521796f4250000107c008b477040f + DOCKER_REV: 408eff66aef6ca2b44446c694c5a56d6ca0460cc # Sequential version number capturing the versions of all tools fetched by # .gitlab/win32-init.sh. @@ -36,6 +36,13 @@ stages: - tags - web +.release: &release + artifacts: + when: always + expire_in: 1 year + only: + - tags + ############################################################ # Runner Tags ############################################################ @@ -106,7 +113,7 @@ typecheck-testsuite: - lint # We allow the submodule checker to fail when run on merge requests (to -# accomodate, e.g., haddock changes not yet upstream) but not on `master` or +# accommodate, e.g., haddock changes not yet upstream) but not on `master` or # Marge jobs. .lint-submods: <<: *only-default @@ -166,7 +173,7 @@ lint-submods-branch: grep TBA libraries/*/changelog.md && ( echo "Error: Found \"TBA\"s in changelogs." exit 1 - ) + ) || exit 0 lint-changelogs: extends: .lint-changelogs @@ -530,7 +537,6 @@ nightly-i386-linux-deb9: .build-x86_64-linux-deb9: extends: .validate-linux - stage: full-build image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV" variables: TEST_ENV: "x86_64-linux-deb9" @@ -541,12 +547,14 @@ nightly-i386-linux-deb9: # Disabled to reduce CI load .validate-x86_64-linux-deb9: extends: .build-x86_64-linux-deb9 + stage: full-build artifacts: when: always expire_in: 2 week nightly-x86_64-linux-deb9: extends: .build-x86_64-linux-deb9 + stage: full-build artifacts: expire_in: 2 year variables: @@ -611,37 +619,86 @@ nightly-x86_64-linux-deb9-integer-simple: variables: - $NIGHTLY -release-x86_64-linux-deb9-dwarf: +release-x86_64-linux-deb9: extends: .validate-linux stage: build image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV" variables: - CONFIGURE_ARGS: "--enable-dwarf-unwind" - BUILD_FLAVOUR: dwarf - TEST_ENV: "x86_64-linux-deb9-dwarf" - BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb9-linux-dwarf.tar.xz" + BUILD_FLAVOUR: perf + TEST_ENV: "x86_64-linux-deb9" + BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb9-linux.tar.xz" artifacts: when: always expire_in: 2 week cache: key: linux-x86_64-deb9 +validate-x86_64-linux-deb9-dwarf: + extends: .build-x86_64-linux-deb9 + stage: build + variables: + CONFIGURE_ARGS: "--enable-dwarf-unwind" + BUILD_FLAVOUR: dwarf + TEST_ENV: "x86_64-linux-deb9-dwarf" + BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb9-linux-dwarf.tar.xz" + +################################# +# x86_64-linux-deb10 +################################# + +.build-x86_64-linux-deb10: + extends: .validate-linux + stage: full-build + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV" + variables: + TEST_ENV: "x86_64-linux-deb10" + BIN_DIST_PREP_TAR_COMP: "./ghc-x86_64-deb10-linux.tar.xz" + XZ: "xz -T0" + cache: + key: linux-x86_64-deb10 + +# Disabled to alleviate CI load +.validate-x86_64-linux-deb10: + extends: .build-x86_64-linux-deb10 + stage: full-build + +nightly-x86_64-linux-deb10: + extends: .build-x86_64-linux-deb10 + artifacts: + expire_in: 2 weeks + variables: + TEST_TYPE: slowtest + only: + variables: + - $NIGHTLY + +release-x86_64-linux-deb10: + <<: *release + extends: .build-x86_64-linux-deb10 ################################# # x86_64-linux-deb8 ################################# -release-x86_64-linux-deb8: +.build-x86_64-linux-deb8: extends: .validate-linux stage: full-build image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb8:$DOCKER_REV" variables: TEST_ENV: "x86_64-linux-deb8" BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb8-linux.tar.xz" - only: - - tags + # Debian 8's Sphinx is too old to support the table directive's :widths: + # option: https://sourceforge.net/p/docutils/patches/120/ + BUILD_SPHINX_HTML: "NO" + BUILD_SPHINX_INFO: "NO" + BUILD_SPHINX_PDF: "NO" + BUILD_SPHINX_MAN: "NO" cache: key: linux-x86_64-deb8 + +release-x86_64-linux-deb8: + <<: *release + extends: .build-x86_64-linux-deb8 artifacts: when: always expire_in: 2 week @@ -669,9 +726,8 @@ release-x86_64-linux-deb8: expire_in: 2 week release-x86_64-linux-alpine: + <<: *release extends: .build-x86_64-linux-alpine - only: - - tags nightly-x86_64-linux-alpine: extends: .build-x86_64-linux-alpine @@ -683,7 +739,7 @@ nightly-x86_64-linux-alpine: # x86_64-linux-centos7 ################################# -release-x86_64-linux-centos7: +.build-x86_64-linux-centos7: extends: .validate-linux stage: full-build image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-centos7:$DOCKER_REV" @@ -693,10 +749,16 @@ release-x86_64-linux-centos7: BUILD_SPHINX_PDF: "NO" TEST_ENV: "x86_64-linux-centos7" BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-centos7-linux.tar.xz" - only: - - tags + # pxz is not available on centos7 for reasons I can't understand + XZ: "xz" + # CentOS seems to default to ascii + LANG: "en_US.UTF-8" cache: key: linux-x86_64-centos7 + +release-x86_64-linux-centos7: + <<: *release + extends: .build-x86_64-linux-centos7 artifacts: when: always expire_in: 2 week @@ -830,7 +892,7 @@ nightly-i386-windows-hadrian: reports: junit: junit.xml paths: - - $BIN_DIST_PREP_TAR_COMP + - "ghc-x86_64-mingw32.tar.xz" - junit.xml validate-x86_64-windows: @@ -857,19 +919,17 @@ nightly-x86_64-windows: # Normal Windows validate builds are profiled; that won't do for releases. release-x86_64-windows: + <<: *release extends: validate-x86_64-windows variables: MSYSTEM: MINGW64 BUILD_FLAVOUR: "perf" CONFIGURE_ARGS: "--target=x86_64-unknown-mingw32" TEST_ENV: "x86_64-windows" - only: - - tags release-i386-windows: + <<: *release extends: .build-windows-make - only: - - tags variables: MSYSTEM: MINGW32 BUILD_FLAVOUR: "perf" @@ -979,6 +1039,7 @@ source-tarball: tags: - x86_64-linux image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV" + when: always dependencies: [] only: - tags @@ -1042,7 +1103,7 @@ nightly-hackage: perf-nofib: stage: testing dependencies: - - release-x86_64-linux-deb9-dwarf + - validate-x86_64-linux-deb9-dwarf image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV" only: refs: diff --git a/.gitlab/prepare-system.sh b/.gitlab/prepare-system.sh index 56dba70065..a8eabe2678 100755 --- a/.gitlab/prepare-system.sh +++ b/.gitlab/prepare-system.sh @@ -13,6 +13,7 @@ if [[ -z ${BUILD_SPHINX_HTML:-} ]]; then BUILD_SPHINX_HTML=YES; fi if [[ -z ${BUILD_SPHINX_PDF:-} ]]; then BUILD_SPHINX_PDF=YES; fi if [[ -z ${INTEGER_LIBRARY:-} ]]; then INTEGER_LIBRARY=integer-gmp; fi if [[ -z ${BUILD_FLAVOUR:-} ]]; then BUILD_FLAVOUR=perf; fi +if [[ -z ${XZ:-} ]]; then XZ=pxz; fi cat > mk/build.mk <<EOF V=1 @@ -23,7 +24,7 @@ BUILD_SPHINX_HTML=$BUILD_SPHINX_HTML BUILD_SPHINX_PDF=$BUILD_SPHINX_PDF BeConservative=YES INTEGER_LIBRARY=$INTEGER_LIBRARY -XZ_CMD=pxz +XZ_CMD=$XZ EOF cat <<EOF >> mk/build.mk diff --git a/.gitlab/win32-init.sh b/.gitlab/win32-init.sh index e30706ef90..aec73ce083 100644 --- a/.gitlab/win32-init.sh +++ b/.gitlab/win32-init.sh @@ -45,5 +45,3 @@ if [ ! -e $toolchain/bin/alex ]; then cp $APPDATA/cabal/bin/alex $toolchain/bin fi -# Install new process to mitigate #17480. -cabal install libraries/process diff --git a/.gitmodules b/.gitmodules index 7f151f685c..79b5622ce9 100644 --- a/.gitmodules +++ b/.gitmodules @@ -109,4 +109,4 @@ url = https://gitlab.haskell.org/ghc/gmp-tarballs.git [submodule "libraries/exceptions"] path = libraries/exceptions - url = https://gitlab.haskell.org/ghc/packages/exceptions + url = https://gitlab.haskell.org/ghc/packages/exceptions.git diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 68b9f00798..1a7db17ccd 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -407,7 +407,7 @@ where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means gp = ...same again, with gm instead of fm -The 'fwrap' is an impedence-matcher that typically does nothing; see +The 'fwrap' is an impedance-matcher that typically does nothing; see Note [ABExport wrapper]. This is a pretty bad translation, because it duplicates all the bindings. diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 52d0448cc6..9955efaeb1 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -431,19 +431,6 @@ data HsExpr p (ArithSeqInfo p) -- For details on above see note [Api annotations] in ApiAnnotation - | HsSCC (XSCC p) - SourceText -- Note [Pragma source text] in BasicTypes - StringLiteral -- "set cost centre" SCC pragma - (LHsExpr p) -- expr whose cost is to be measured - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, - -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCoreAnn (XCoreAnn p) - SourceText -- Note [Pragma source text] in BasicTypes - StringLiteral -- hdaume: core annotation - (LHsExpr p) ----------------------------------------------------------- -- MetaHaskell Extensions @@ -511,25 +498,9 @@ data HsExpr p Int -- module-local tick number for False (LHsExpr p) -- sub-expression - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnMinus', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsTickPragma -- A pragma introduced tick - (XTickPragma p) - SourceText -- Note [Pragma source text] in BasicTypes - (StringLiteral,(Int,Int),(Int,Int)) - -- external span for this tick - ((SourceText,SourceText),(SourceText,SourceText)) - -- Source text for the four integers used in the span. - -- See note [Pragma source text] in BasicTypes - (LHsExpr p) + --------------------------------------- + -- Expressions annotated with pragmas, written as {-# ... #-} + | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) --------------------------------------- -- Finally, HsWrap appears only in typechecker output @@ -625,8 +596,6 @@ type instance XArithSeq GhcPs = NoExtField type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcTc = PostTcExpr -type instance XSCC (GhcPass _) = NoExtField -type instance XCoreAnn (GhcPass _) = NoExtField type instance XBracket (GhcPass _) = NoExtField type instance XRnBracketOut (GhcPass _) = NoExtField @@ -641,12 +610,54 @@ type instance XStatic GhcTc = NameSet type instance XTick (GhcPass _) = NoExtField type instance XBinTick (GhcPass _) = NoExtField -type instance XTickPragma (GhcPass _) = NoExtField + +type instance XPragE (GhcPass _) = NoExtField + type instance XWrap (GhcPass _) = NoExtField type instance XXExpr (GhcPass _) = NoExtCon -- --------------------------------------------------------------------- +-- | A pragma, written as {-# ... #-}, that may appear within an expression. +data HsPragE p + = HsPragSCC (XSCC p) + SourceText -- Note [Pragma source text] in BasicTypes + StringLiteral -- "set cost centre" SCC pragma + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, + -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsPragCore (XCoreAnn p) + SourceText -- Note [Pragma source text] in BasicTypes + StringLiteral -- hdaume: core annotation + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnMinus', + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsPragTick -- A pragma introduced tick + (XTickPragma p) + SourceText -- Note [Pragma source text] in BasicTypes + (StringLiteral,(Int,Int),(Int,Int)) + -- external span for this tick + ((SourceText,SourceText),(SourceText,SourceText)) + -- Source text for the four integers used in the span. + -- See note [Pragma source text] in BasicTypes + + | XHsPragE (XXPragE p) + +type instance XSCC (GhcPass _) = NoExtField +type instance XCoreAnn (GhcPass _) = NoExtField +type instance XTickPragma (GhcPass _) = NoExtField +type instance XXPragE (GhcPass _) = NoExtCon + -- | Located Haskell Tuple Argument -- -- 'HsTupArg' is used for tuple sections @@ -857,10 +868,7 @@ ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit ppr_expr (HsPar _ e) = parens (ppr_lexpr e) -ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) - = vcat [pprWithSourceText stc (text "{-# CORE") - <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" - , ppr_lexpr e] +ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e [] @@ -912,7 +920,7 @@ ppr_expr (SectionR _ op expr) ppr_expr (ExplicitTuple _ exprs boxity) -- Special-case unary boxed tuples so that they are pretty-printed as -- `Unit x`, not `(x)` - | [dL -> L _ (Present _ expr)] <- exprs + | [L _ (Present _ expr)] <- exprs , Boxed <- boxity = hsep [text (mkTupleStr Boxed 1), ppr expr] | otherwise @@ -990,13 +998,6 @@ ppr_expr (ExprWithTySig _ expr sig) ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) - = sep [ pprWithSourceText st (text "{-# SCC") - -- no doublequotes if stl empty, for the case where the SCC was written - -- without quotes. - <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", - ppr expr ] - ppr_expr (HsWrap _ co_fn e) = pprHsWrapper co_fn (\parens -> if parens then pprExpr e else pprExpr e) @@ -1027,13 +1028,6 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) ppr tickIdFalse, text ">(", ppr exp, text ")"] -ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) - = pprTicks (ppr exp) $ - hcat [text "tickpragma<", - pprExternalSrcLoc externalSrcLoc, - text ">(", - ppr exp, - text ")"] ppr_expr (HsRecFld _ f) = ppr f ppr_expr (XExpr x) = ppr x @@ -1110,7 +1104,6 @@ hsExprNeedsParens p = go go (HsLit _ l) = hsLitNeedsParens p l go (HsOverLit _ ol) = hsOverLitNeedsParens p ol go (HsPar{}) = False - go (HsCoreAnn _ _ _ (L _ e)) = go e go (HsApp{}) = p >= appPrec go (HsAppType {}) = p >= appPrec go (OpApp{}) = p >= opPrec @@ -1132,7 +1125,7 @@ hsExprNeedsParens p = go go (RecordUpd{}) = False go (ExprWithTySig{}) = p >= sigPrec go (ArithSeq{}) = False - go (HsSCC{}) = p >= appPrec + go (HsPragE{}) = p >= appPrec go (HsWrap _ _ e) = go e go (HsSpliceE{}) = False go (HsBracket{}) = False @@ -1142,7 +1135,6 @@ hsExprNeedsParens p = go go (HsStatic{}) = p >= appPrec go (HsTick _ _ (L _ e)) = go e go (HsBinTick _ _ _ (L _ e)) = go e - go (HsTickPragma _ _ _ _ (L _ e)) = go e go (RecordCon{}) = False go (HsRecFld{}) = False go (XExpr{}) = True @@ -1172,6 +1164,24 @@ isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) isAtomicHsExpr (HsRecFld{}) = True isAtomicHsExpr _ = False +instance Outputable (HsPragE (GhcPass p)) where + ppr (HsPragCore _ stc (StringLiteral sta s)) = + pprWithSourceText stc (text "{-# CORE") + <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" + ppr (HsPragSCC _ st (StringLiteral stl lbl)) = + pprWithSourceText st (text "{-# SCC") + -- no doublequotes if stl empty, for the case where the SCC was written + -- without quotes. + <+> pprWithSourceText stl (ftext lbl) <+> text "#-}" + ppr (HsPragTick _ st (StringLiteral sta s, (v1,v2), (v3,v4)) ((s1,s2),(s3,s4))) = + pprWithSourceText st (text "{-# GENERATED") + <+> pprWithSourceText sta (doubleQuotes $ ftext s) + <+> pprWithSourceText s1 (ppr v1) <+> char ':' <+> pprWithSourceText s2 (ppr v2) + <+> char '-' + <+> pprWithSourceText s3 (ppr v3) <+> char ':' <+> pprWithSourceText s4 (ppr v4) + <+> text "#-}" + ppr (XHsPragE x) = noExtCon x + {- ************************************************************************ * * @@ -2308,9 +2318,8 @@ type instance XXSplice (GhcPass _) = NoExtCon -- type captures explicitly how it was originally written, for use in the pretty -- printer. data SpliceDecoration - = HasParens -- ^ $( splice ) or $$( splice ) - | HasDollar -- ^ $splice or $$splice - | NoParens -- ^ bare splice + = DollarSplice -- ^ $splice or $$splice + | BareSplice -- ^ bare splice deriving (Data, Eq, Show) instance Outputable SpliceDecoration where @@ -2452,12 +2461,12 @@ instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where pprPendingSplice :: (OutputableBndrId p) => SplicePointName -> LHsExpr (GhcPass p) -> SDoc -pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) +pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensHsExpr e)) pprSpliceDecl :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e -pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" +pprSpliceDecl e ExplicitSplice = text "$" <> ppr_splice_decl e pprSpliceDecl e ImplicitSplice = ppr_splice_decl e ppr_splice_decl :: (OutputableBndrId p) @@ -2466,17 +2475,13 @@ ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty ppr_splice_decl e = pprSplice e pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc -pprSplice (HsTypedSplice _ HasParens n e) - = ppr_splice (text "$$(") n e (text ")") -pprSplice (HsTypedSplice _ HasDollar n e) +pprSplice (HsTypedSplice _ DollarSplice n e) = ppr_splice (text "$$") n e empty -pprSplice (HsTypedSplice _ NoParens n e) - = ppr_splice empty n e empty -pprSplice (HsUntypedSplice _ HasParens n e) - = ppr_splice (text "$(") n e (text ")") -pprSplice (HsUntypedSplice _ HasDollar n e) +pprSplice (HsTypedSplice _ BareSplice _ _ ) + = panic "Bare typed splice" -- impossible +pprSplice (HsUntypedSplice _ DollarSplice n e) = ppr_splice (text "$") n e empty -pprSplice (HsUntypedSplice _ NoParens n e) +pprSplice (HsUntypedSplice _ BareSplice n e) = ppr_splice empty n e empty pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s pprSplice (HsSpliced _ _ thing) = ppr thing diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index 6b1042700a..be0333933a 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -606,8 +606,6 @@ type family XRecordCon x type family XRecordUpd x type family XExprWithTySig x type family XArithSeq x -type family XSCC x -type family XCoreAnn x type family XBracket x type family XRnBracketOut x type family XTcBracketOut x @@ -616,10 +614,15 @@ type family XProc x type family XStatic x type family XTick x type family XBinTick x -type family XTickPragma x +type family XPragE x type family XWrap x type family XXExpr x +type family XSCC x +type family XCoreAnn x +type family XTickPragma x +type family XXPragE x + type ForallXExpr (c :: * -> Constraint) (x :: *) = ( c (XVar x) , c (XUnboundVar x) diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index b3a33df43c..5f6fae2cb2 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -247,6 +247,11 @@ deriving instance Data (SyntaxExpr GhcPs) deriving instance Data (SyntaxExpr GhcRn) deriving instance Data (SyntaxExpr GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsPragE p) +deriving instance Data (HsPragE GhcPs) +deriving instance Data (HsPragE GhcRn) +deriving instance Data (HsPragE GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsExpr p) deriving instance Data (HsExpr GhcPs) deriving instance Data (HsExpr GhcRn) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index cae7144a8c..d8ae451ee9 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -710,7 +710,7 @@ isIrrefutableHsPat go (ConPatIn {}) = False -- Conservative go (ConPatOut - { pat_con = (dL->L _ (RealDataCon con)) + { pat_con = L _ (RealDataCon con) , pat_args = details }) = isJust (tyConSingleDataCon_maybe (dataConTyCon con)) @@ -718,9 +718,8 @@ isIrrefutableHsPat -- the latter is false of existentials. See #4439 && all goL (hsConPatArgs details) go (ConPatOut - { pat_con = (dL->L _ (PatSynCon _pat)) }) + { pat_con = L _ (PatSynCon _pat) }) = False -- Conservative - go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884 go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False @@ -790,8 +789,8 @@ conPatNeedsParens p = go -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) -parenthesizePat p lpat@(dL->L loc pat) - | patNeedsParens p pat = cL loc (ParPat noExtField lpat) +parenthesizePat p lpat@(L loc pat) + | patNeedsParens p pat = L loc (ParPat noExtField lpat) | otherwise = lpat {- diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index fcf22584cb..e92928c78f 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -84,7 +84,6 @@ import Name( Name, NamedThing(getName) ) import RdrName ( RdrName ) import DataCon( HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..) ) -import TysPrim( funTyConName ) import TysWiredIn( mkTupleStr ) import Type import GHC.Hs.Doc @@ -1064,14 +1063,14 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) -hsLTyVarLocName = onHasSrcSpan hsTyVarName +hsLTyVarLocName = mapLoc hsTyVarName hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) -hsLTyVarBndrToType = onHasSrcSpan cvt +hsLTyVarBndrToType = mapLoc cvt where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n cvt (KindedTyVar _ (L name_loc n) kind) = HsKindSig noExtField @@ -1151,8 +1150,6 @@ mkHsAppKindTy ext ty k -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) -- Breaks up any parens in the result type: -- splitHsFunType (a -> (b -> c)) = ([a,b], c) --- Also deals with (->) t1 t2; that is why it only works on LHsType Name --- (see #9096) splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) splitHsFunType (L _ (HsParTy _ ty)) = splitHsFunType ty @@ -1160,19 +1157,6 @@ splitHsFunType (L _ (HsParTy _ ty)) splitHsFunType (L _ (HsFunTy _ x y)) | (args, res) <- splitHsFunType y = (x:args, res) -{- This is not so correct, because it won't work with visible kind app, in case - someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing - ConDeclGADT abstract syntax -} -splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) - = go t1 [t2] - where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName - , [t1,t2] <- tys - , (args, res) <- splitHsFunType t2 - = (t1:args, res) - go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys) - go (L _ (HsParTy _ ty)) tys = go ty tys - go _ _ = ([], orig_ty) -- Failure to match splitHsFunType other = ([], other) diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 92b9290fb1..1b386fd703 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -48,7 +48,7 @@ module GHC.Hs.Utils( mkChunkified, chunkify, -- * Bindings - mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, + mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, mkPatSynBind, isInfixFunBind, @@ -145,15 +145,15 @@ from their components, compared with the @nl*@ functions below which just attach 'noSrcSpan' to everything. -} --- | e => (e) +-- | @e => (e)@ mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = cL (getLoc e) (HsPar noExtField e) +mkHsPar e = L (getLoc e) (HsPar noExtField e) mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs - = cL loc $ + = L loc $ Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats , m_grhss = unguardedGRHSs rhs } where @@ -163,12 +163,12 @@ mkSimpleMatch ctxt pats rhs unguardedGRHSs :: Located (body (GhcPass p)) -> GRHSs (GhcPass p) (Located (body (GhcPass p))) -unguardedGRHSs rhs@(dL->L loc _) +unguardedGRHSs rhs@(L loc _) = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds) unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] -unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)] +unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)] mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField) => Origin -> [LMatch name (Located (body name))] @@ -179,7 +179,7 @@ mkMatchGroup origin matches = MG { mg_ext = noExtField mkLocatedList :: [Located a] -> Located [Located a] mkLocatedList [] = noLoc [] -mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms +mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2) @@ -196,7 +196,7 @@ mkHsAppTypes = foldl' mkHsAppType mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches)) +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) where matches = mkMatchGroup Generated [mkSimpleMatch LambdaExpr pats' body] @@ -222,16 +222,16 @@ nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs --------- Adding parens --------- --- | Wrap in parens if (hsExprNeedsParens appPrec) says it needs them --- So 'f x' becomes '(f x)', but '3' stays as '3' +-- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them +-- So @f x@ becomes @(f x)@, but @3@ stays as @3@. mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsPar le@(dL->L loc e) - | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le) +mkLHsPar le@(L loc e) + | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le) | otherwise = le mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -mkParPat lp@(dL->L loc p) - | patNeedsParens appPrec p = cL loc (ParPat noExtField lp) +mkParPat lp@(L loc p) + | patNeedsParens appPrec p = L loc (ParPat noExtField lp) | otherwise = lp nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) @@ -277,7 +277,7 @@ mkHsIsString src s = OverLit noExtField (HsIsString src s) noExpr mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts) mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) where - last_stmt = cL (getLoc expr) $ mkLastStmt expr + last_stmt = L (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) @@ -387,7 +387,7 @@ mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) nlHsVar n = noLoc (HsVar noExtField (noLoc n)) --- | NB: Only for LHsExpr **Id** +-- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con)) @@ -531,7 +531,7 @@ missingTupArg = Missing noExtField mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed +mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed -- | The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) @@ -620,22 +620,22 @@ mkHsSigEnv get_info sigs -- of which use this function where (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs - is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True - is_gen_dm_sig _ = False + is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True + is_gen_dm_sig _ = False mk_pairs :: [LSig GhcRn] -> [(Name, a)] mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs - , (dL->L _ n) <- ns ] + , L _ n <- ns ] mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] --- ^ Convert TypeSig to ClassOpSig +-- ^ Convert 'TypeSig' to 'ClassOpSig'. -- The former is what is parsed, but the latter is -- what we need in class/instance declarations mkClassOpSigs sigs = map fiddle sigs where - fiddle (dL->L loc (TypeSig _ nms ty)) - = cL loc (ClassOpSig noExtField False nms (dropWildCards ty)) + fiddle (L loc (TypeSig _ nms ty)) + = L loc (ClassOpSig noExtField False nms (dropWildCards ty)) fiddle sig = sig typeToLHsType :: Type -> LHsType GhcPs @@ -753,10 +753,10 @@ positions in the kind of the tycon. ********************************************************************* -} mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) +mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) --- | Avoid (HsWrap co (HsWrap co' _)). --- See Note [Detecting forced eta expansion] in DsExpr +-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@. +-- See Note [Detecting forced eta expansion] in "DsExpr" mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e @@ -771,14 +771,14 @@ mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) +mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) mkHsCmdWrap w cmd | isIdHsWrapper w = cmd | otherwise = HsCmdWrap noExtField w cmd mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) +mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p @@ -800,14 +800,15 @@ l ************************************************************************ -} -mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] +mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- ^ Not infix, with place holders for coercion and free vars -mkFunBind fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup Generated ms - , fun_co_fn = idHsWrapper - , fun_ext = noExtField - , fun_tick = [] } +mkFunBind origin fn ms + = FunBind { fun_id = fn + , fun_matches = mkMatchGroup origin ms + , fun_co_fn = idHsWrapper + , fun_ext = noExtField + , fun_tick = [] } mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn @@ -820,10 +821,10 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn , fun_tick = [] } mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs -mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs +mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) -mkVarBind var rhs = cL (getLoc rhs) $ +mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_ext = noExtField, var_id = var, var_rhs = rhs, var_inline = False } @@ -846,11 +847,13 @@ isInfixFunBind _ = False ------------ -mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs] +-- | Convenience function using 'mkFunBind'. +-- This is for generated bindings only, do not use for user-written code. +mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs -mk_easy_FunBind loc fun pats expr - = cL loc $ mkFunBind (cL loc fun) - [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr +mkSimpleGeneratedFunBind loc fun pats expr + = L loc $ mkFunBind Generated (L loc fun) + [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr (noLoc emptyLocalBinds)] -- | Make a prefix, non-strict function 'HsMatchContext' @@ -870,8 +873,8 @@ mkMatch ctxt pats expr lbinds , m_pats = map paren pats , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) where - paren lp@(dL->L l p) - | patNeedsParens appPrec p = cL l (ParPat noExtField lp) + paren lp@(L l p) + | patNeedsParens appPrec p = L l (ParPat noExtField lp) | otherwise = lp {- @@ -951,7 +954,7 @@ isBangedHsBind :: HsBind GhcTc -> Bool isBangedHsBind (AbsBinds { abs_binds = binds }) = anyBag (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches}) - | [dL->L _ match] <- unLoc $ mg_alts matches + | [L _ match] <- unLoc $ mg_alts matches , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match = True isBangedHsBind (PatBind {pat_lhs = pat}) @@ -969,20 +972,20 @@ collectLocalBinders (XHsLocalBindsLR _) = [] collectHsIdBinders, collectHsValBinders :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] --- ^ Collect Id binders only, or Ids + pattern synonyms, respectively +-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively collectHsIdBinders = collect_hs_val_binders True collectHsValBinders = collect_hs_val_binders False -collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=> - HsBindLR p idR -> [IdP p] --- ^ Collect both Ids and pattern-synonym binders +collectHsBindBinders :: XRec pass Pat ~ Located (Pat pass) => + HsBindLR pass idR -> [IdP pass] +-- ^ Collect both 'Id's and pattern-synonym binders collectHsBindBinders b = collect_bind False b [] collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] collectHsBindsBinders binds = collect_binds False binds [] collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)] --- ^ Same as collectHsBindsBinders, but works over a list of bindings +-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings collectHsBindListBinders = foldr (collect_bind False . unLoc) [] collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) @@ -997,26 +1000,28 @@ collect_out_binds ps = foldr (collect_binds ps . snd) [] collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] -> [IdP (GhcPass p)] --- ^ Collect Ids, or Ids + pattern synonyms, depending on boolean flag +-- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds -collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] +collect_bind :: XRec pass Pat ~ Located (Pat pass) => + Bool -> HsBindLR pass idR -> + [IdP pass] -> [IdP pass] collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc -collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc +collect_bind _ (FunBind { fun_id = L _ f }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc -- I don't think we want the binders from the abe_binds -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc +collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc | otherwise = ps : acc collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc collect_bind _ (XHsBindsLR _) acc = acc collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)] --- ^ Used exclusively for the bindings of an instance decl which are all FunBinds +-- ^ Used exclusively for the bindings of an instance decl which are all +-- 'FunBinds' collectMethodBinders binds = foldr (get . unLoc) [] binds where get (FunBind { fun_id = f }) fs = f : fs @@ -1063,8 +1068,8 @@ collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] collectPatsBinders pats = foldr collect_lpat [] pats ------------- -collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - LPat p -> [IdP p] -> [IdP p] +collect_lpat :: XRec pass Pat ~ Located (Pat pass) => + LPat pass -> [IdP pass] -> [IdP pass] collect_lpat p bndrs = go (unLoc p) where @@ -1157,46 +1162,44 @@ hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p)) -- Each returned (Located name) has a SrcSpan for the /whole/ declaration. -- See Note [SrcSpan for binders] -hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl - { fdLName = (dL->L _ name) } })) - = ([cL loc name], []) -hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec })) +hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl + { fdLName = (L _ name) } })) + = ([L loc name], []) +hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl nec })) = noExtCon nec -hsLTyClDeclBinders (dL->L loc (SynDecl - { tcdLName = (dL->L _ name) })) - = ([cL loc name], []) -hsLTyClDeclBinders (dL->L loc (ClassDecl - { tcdLName = (dL->L _ cls_name) +hsLTyClDeclBinders (L loc (SynDecl + { tcdLName = (L _ name) })) + = ([L loc name], []) +hsLTyClDeclBinders (L loc (ClassDecl + { tcdLName = (L _ cls_name) , tcdSigs = sigs , tcdATs = ats })) - = (cL loc cls_name : - [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl + = (L loc cls_name : + [ L fam_loc fam_name | (L fam_loc (FamilyDecl { fdLName = L _ fam_name })) <- ats ] ++ - [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs - , (dL->L _ mem_name) <- ns ] + [ L mem_loc mem_name | (L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (L _ mem_name) <- ns ] , []) -hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) - , tcdDataDefn = defn })) - = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn -hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec -hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" - -- due to #15884 +hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) + , tcdDataDefn = defn })) + = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn +hsLTyClDeclBinders (L _ (XTyClDecl nec)) = noExtCon nec ------------------- hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] -- ^ See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls - = [ cL decl_loc n - | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) })) + = [ L decl_loc n + | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] ------------------- hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym --- names are collected by collectHsValBinders. +-- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _)) = foldr addPatSynSelector [] . unionManyBags $ map snd binds @@ -1210,27 +1213,25 @@ addPatSynSelector bind sels getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds = [ psb | (_, lbinds) <- binds - , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ] + , L _ (PatSynBind _ psb) <- bagToList lbinds ] ------------------- hsLInstDeclBinders :: LInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -hsLInstDeclBinders (dL->L _ (ClsInstD +hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis }})) = foldMap (hsDataFamInstBinders . unLoc) dfis -hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) +hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) = hsDataFamInstBinders fi -hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty -hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec))) +hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty +hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec -hsLInstDeclBinders (dL->L _ (XInstDecl nec)) +hsLInstDeclBinders (L _ (XInstDecl nec)) = noExtCon nec -hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" - -- due to #15884 ------------------- --- | the SrcLoc returned are for the whole declarations, not just the names +-- | the 'SrcLoc' returned are for the whole declarations, not just the names hsDataFamInstBinders :: DataFamInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = @@ -1244,7 +1245,7 @@ hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec ------------------- --- | the SrcLoc returned are for the whole declarations, not just the names +-- | the 'SrcLoc' returned are for the whole declarations, not just the names hsDataDefnBinders :: HsDataDefn (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) @@ -1275,13 +1276,13 @@ hsConDeclsBinders cons -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_args = args } - -> (map (cL loc . unLoc) names ++ ns, flds ++ fs) + -> (map (L loc . unLoc) names ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs ConDeclH98 { con_name = name, con_args = args } - -> ([cL loc (unLoc name)] ++ ns, flds ++ fs) + -> ([L loc (unLoc name)] ++ ns, flds ++ fs) where (remSeen', flds) = get_flds remSeen args (ns, fs) = go remSeen' rs diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index c712055d70..86a9717c02 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -282,7 +282,7 @@ checkSingle' locn var p = do (Covered , _ ) -> plain -- useful (NotCovered, NotDiverged) -> plain { pmresultRedundant = m } -- redundant (NotCovered, Diverged ) -> plain { pmresultInaccessible = m } -- inaccessible rhs - where m = [cL locn [cL locn p]] + where m = [L locn [L locn p]] -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. @@ -293,7 +293,7 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do dflags <- getDynFlags let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss) dsMatchContext = DsMatchContext hs_ctx combinedLoc - match = cL combinedLoc $ + match = L combinedLoc $ Match { m_ext = noExtField , m_ctxt = hs_ctx , m_pats = [] @@ -360,8 +360,8 @@ checkMatches' vars matches = do (NotCovered, Diverged ) -> (rs, final_u, m:is, pc1 Semi.<> pc2) hsLMatchToLPats :: LMatch id body -> Located [LPat id] - hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats - hsLMatchToLPats _ = panic "checkMatches'" + hsLMatchToLPats (L l (Match { m_pats = pats })) = L l pats + hsLMatchToLPats _ = panic "checkMatches'" getNFirstUncovered :: [Id] -> Int -> [Delta] -> DsM [Delta] getNFirstUncovered _ 0 _ = pure [] @@ -465,7 +465,7 @@ translatePat fam_insts x pat = case pat of -- (x@pat) ==> Translate pat with x as match var and handle impedance -- mismatch with incoming match var - AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p + AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p SigPat _ p _ty -> translateLPat fam_insts x p @@ -481,7 +481,7 @@ translatePat fam_insts x pat = case pat of pure (PmLet y (wrap_rhs_y (Var x)) : grds) -- (n + k) ===> let b = x >= k, True <- b, let n = x-k - NPlusKPat _pat_ty (dL->L _ n) k1 k2 ge minus -> do + NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do b <- mkPmId boolTy let grd_b = vanillaConGrd b trueDataCon [] [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2] @@ -527,14 +527,14 @@ translatePat fam_insts x pat = case pat of -- -- See #14547, especially comment#9 and comment#10. - ConPatOut { pat_con = (dL->L _ con) + ConPatOut { pat_con = L _ con , pat_arg_tys = arg_tys , pat_tvs = ex_tvs , pat_dicts = dicts , pat_args = ps } -> do translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps - NPat ty (dL->L _ olit) mb_neg _ -> do + NPat ty (L _ olit) mb_neg _ -> do -- See Note [Literal short cut] in MatchLit.hs -- We inline the Literal short cut for @ty@ here, because @ty@ is more -- precise than the field of OverLitTc, which is all that dsOverLit (which @@ -657,7 +657,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case -- Translate a single match translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (GrdVec, [GrdVec]) -translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) +translateMatch fam_insts vars (L _ (Match { m_pats = pats, m_grhss = grhss })) = do pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats guards' <- mapM (translateGuards fam_insts) guards @@ -665,8 +665,8 @@ translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss } return (pats', guards') where extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc] - extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs - extractGuards _ = panic "translateMatch" + extractGuards (L _ (GRHS _ gs _)) = map unLoc gs + extractGuards _ = panic "translateMatch" guards = map extractGuards (grhssGRHSs grhss) translateMatch _ _ _ = panic "translateMatch" @@ -947,7 +947,7 @@ Main functions are: * pmCheck :: PatVec -> [PatVec] -> ValVec -> Delta -> DsM PartialResult This function implements functions `covered`, `uncovered` and - `divergent` from the paper at once. Calls out to the auxilary function + `divergent` from the paper at once. Calls out to the auxiliary function `pmCheckGuards` for handling (possibly multiple) guarded RHSs when the whole clause is checked. Slightly different from the paper because it does not even produce the covered and uncovered sets. Since we only care about whether a @@ -1247,10 +1247,10 @@ dsPmWarn dflags ctx@(DsMatchContext kind loc) vars pm_result when (approx && (exists_u || exists_i)) $ putSrcSpanDs loc (warnDs NoReason approx_msg) - when exists_r $ forM_ redundant $ \(dL->L l q) -> do + when exists_r $ forM_ redundant $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "is redundant")) - when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do + when exists_i $ forM_ inaccessible $ \(L l q) -> do putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns) (pprEqn q "has inaccessible right hand side")) when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $ @@ -1366,7 +1366,7 @@ pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun (ppr_match, pref) = case kind of - FunRhs { mc_fun = (dL->L _ fun) } + FunRhs { mc_fun = L _ fun } -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp) diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 9e192a0ac8..d373b79d0c 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -180,7 +180,7 @@ cgBind (StgRec pairs) 3. emit all the inits, and then all the bodies We'd rather not have separate functions to do steps 1 and 2 for - each binding, since in pratice they share a lot of code. So we + each binding, since in practice they share a lot of code. So we have just one function, cgRhs, that returns a pair of the CgIdInfo for step 1, and a monadic computation to generate the code in step 2. diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index e309d061a8..3728c0cac2 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -1426,10 +1426,17 @@ dispatchPrimop dflags = \case if ncg && (x86ish || ppc) || llvm then Left (MO_U_Mul2 (wordWidth dflags)) else Right genericWordMul2Op + + IntMul2Op -> \_ -> OpDest_CallishHandledLater $ + if ncg && x86ish + then Left (MO_S_Mul2 (wordWidth dflags)) + else Right genericIntMul2Op + FloatFabsOp -> \_ -> OpDest_CallishHandledLater $ if (ncg && x86ish || ppc) || llvm then Left MO_F32_Fabs else Right $ genericFabsOp W32 + DoubleFabsOp -> \_ -> OpDest_CallishHandledLater $ if (ncg && x86ish || ppc) || llvm then Left MO_F64_Fabs @@ -1870,6 +1877,31 @@ genericWordMul2Op [res_h, res_l] [arg_x, arg_y] topHalf (CmmReg r)])] genericWordMul2Op _ _ = panic "genericWordMul2Op" +genericIntMul2Op :: GenericOp +genericIntMul2Op [res_c, res_h, res_l] [arg_x, arg_y] + = do dflags <- getDynFlags + -- Implement algorithm from Hacker's Delight, 2nd edition, p.174 + let t = cmmExprType dflags arg_x + p <- newTemp t + -- 1) compute the multiplication as if numbers were unsigned + let wordMul2 = fromMaybe (panic "Unsupported out-of-line WordMul2Op") + (emitPrimOp dflags WordMul2Op [arg_x,arg_y]) + wordMul2 [p,res_l] + -- 2) correct the high bits of the unsigned result + let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1] + sub x y = CmmMachOp (MO_Sub ww) [x, y] + and x y = CmmMachOp (MO_And ww) [x, y] + neq x y = CmmMachOp (MO_Ne ww) [x, y] + f x y = (carryFill x) `and` y + wwm1 = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww) + rl x = CmmReg (CmmLocal x) + ww = wordWidth dflags + emit $ catAGraphs + [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x) + , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l)) + ] +genericIntMul2Op _ _ = panic "genericIntMul2Op" + -- This replicates what we had in libraries/base/GHC/Float.hs: -- -- abs x | x == 0 = 0 -- handles (-0.0) diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index ce8ef61f17..4743b79622 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -328,14 +328,14 @@ ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () ldvEnterClosure closure_info node_reg = do dflags <- getDynFlags let tag = funTag dflags closure_info - -- don't forget to substract node's tag + -- don't forget to subtract node's tag ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag)) ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do dflags <- getDynFlags - let -- don't forget to substract node's tag + let -- don't forget to subtract node's tag ldv_wd = ldvWord dflags cl_ptr new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags)))) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 7d913ff4bf..2a813344df 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -58,27 +58,28 @@ import System.IO.Unsafe ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] -convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds)) +convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] +convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds)) where cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) -convertToHsExpr loc e - = initCvt loc $ wrapMsg "expression" e $ cvtl e +convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) +convertToHsExpr origin loc e + = initCvt origin loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) -convertToPat loc p - = initCvt loc $ wrapMsg "pattern" p $ cvtPat p +convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) +convertToPat origin loc p + = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) -convertToHsType loc t - = initCvt loc $ wrapMsg "type" t $ cvtType t +convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) +convertToHsType origin loc t + = initCvt origin loc $ wrapMsg "type" t $ cvtType t ------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } +newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) } deriving (Functor) - -- Push down the source location; + -- Push down the Origin (that is configurable by + -- -fenable-th-splice-warnings) and source location; -- Can fail, with a single error message -- NB: If the conversion succeeds with (Right x), there should @@ -91,45 +92,47 @@ newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } -- the spliced-in declarations get a location that at least relates to the splice point instance Applicative CvtM where - pure x = CvtM $ \loc -> Right (loc,x) + pure x = CvtM $ \_ loc -> Right (loc,x) (<*>) = ap instance Monad CvtM where - (CvtM m) >>= k = CvtM $ \loc -> case m loc of - Left err -> Left err - Right (loc',v) -> unCvtM (k v) loc' + (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of + Left err -> Left err + Right (loc',v) -> unCvtM (k v) origin loc' -initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a -initCvt loc (CvtM m) = fmap snd (m loc) +initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a +initCvt origin loc (CvtM m) = fmap snd (m origin loc) force :: a -> CvtM () force a = a `seq` return () failWith :: MsgDoc -> CvtM a -failWith m = CvtM (\_ -> Left m) +failWith m = CvtM (\_ _ -> Left m) + +getOrigin :: CvtM Origin +getOrigin = CvtM (\origin loc -> Right (loc,origin)) getL :: CvtM SrcSpan -getL = CvtM (\loc -> Right (loc,loc)) +getL = CvtM (\_ loc -> Right (loc,loc)) setL :: SrcSpan -> CvtM () -setL loc = CvtM (\_ -> Right (loc, ())) +setL loc = CvtM (\_ _ -> Right (loc, ())) -returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a -returnL x = CvtM (\loc -> Right (loc, cL loc x)) +returnL :: a -> CvtM (Located a) +returnL x = CvtM (\_ loc -> Right (loc, L loc x)) -returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a) +returnJustL :: a -> CvtM (Maybe (Located a)) returnJustL = fmap Just . returnL -wrapParL :: HasSrcSpan a => - (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a) -wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x))) +wrapParL :: (Located a -> a) -> a -> CvtM a +wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x))) wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g wrapMsg "declaration" dec thing wrapMsg what item (CvtM m) - = CvtM (\loc -> case m loc of - Left err -> Left (err $$ getPprStyle msg) - Right v -> Right v) + = CvtM $ \origin loc -> case m origin loc of + Left err -> Left (err $$ getPprStyle msg) + Right v -> Right v where -- Show the item in pretty syntax normally, -- but with all its constructors if you say -dppr-debug @@ -138,10 +141,10 @@ wrapMsg what item (CvtM m) then text (show item) else text (pprint item)) -wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a -wrapL (CvtM m) = CvtM (\loc -> case m loc of - Left err -> Left err - Right (loc',v) -> Right (loc',cL loc v)) +wrapL :: CvtM a -> CvtM (Located a) +wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of + Left err -> Left err + Right (loc', v) -> Right (loc', L loc v) ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] @@ -152,7 +155,8 @@ cvtDec (TH.ValD pat body ds) | TH.VarP s <- pat = do { s' <- vNameL s ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) - ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] } + ; th_origin <- getOrigin + ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] } | otherwise = do { pat' <- cvtPat pat @@ -172,7 +176,8 @@ cvtDec (TH.FunD nm cls) | otherwise = do { nm' <- vNameL nm ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls - ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' } + ; th_origin <- getOrigin + ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' } cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm @@ -273,14 +278,14 @@ cvtDec (InstanceD o ctxt ty decs) ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext funPrec ctxt - ; (dL->L loc ty') <- cvtType ty - ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty' + ; (L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty' ; returnJustL $ InstD noExtField $ ClsInstD noExtField $ ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts' - , cid_overlap_mode = fmap (cL loc . overlap) o } } + , cid_overlap_mode = fmap (L loc . overlap) o } } where overlap pragma = case pragma of @@ -344,7 +349,7 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) , feqn_fixity = Prefix } }}} cvtDec (TySynInstD eqn) - = do { (dL->L _ eqn') <- cvtTySynEqn eqn + = do { (L _ eqn') <- cvtTySynEqn eqn ; returnJustL $ InstD noExtField $ TyFamInstD { tfid_ext = noExtField , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } @@ -370,8 +375,8 @@ cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext funPrec cxt ; ds' <- traverse cvtDerivStrategy ds - ; (dL->L loc ty') <- cvtType ty - ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty' + ; (L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty' ; returnJustL $ DerivD noExtField $ DerivDecl { deriv_ext =noExtField , deriv_strategy = ds' @@ -403,7 +408,8 @@ cvtDec (TH.PatSynD nm args dir pat) cvtDir _ ImplBidir = return ImplicitBidirectional cvtDir n (ExplBidir cls) = do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls - ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } + ; th_origin <- getOrigin + ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms } cvtDec (TH.PatSynSigD nm ty) = do { nm' <- cNameL nm @@ -464,8 +470,6 @@ cvt_ci_decs doc decs ; let (binds', prob_fams') = partitionWith is_bind prob_binds' ; let (fams', bads) = partitionWith is_fam_decl prob_fams' ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - --We use FromSource as the origin of the bind - -- because the TH declaration is user-written ; return (listToBag binds', sigs', fams', ats', adts') } ---------------- @@ -518,29 +522,29 @@ cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) ------------------------------------------------------------------- is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) -is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d) +is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d) is_fam_decl decl = Right decl is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) -is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) - = Left (cL loc d) +is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) + = Left (L loc d) is_tyfam_inst decl = Right decl is_datafam_inst :: LHsDecl GhcPs -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) -is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) - = Left (cL loc d) +is_datafam_inst (L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) + = Left (L loc d) is_datafam_inst decl = Right decl is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) -is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig) -is_sig decl = Right decl +is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig) +is_sig decl = Right decl is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) -is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind) -is_bind decl = Right decl +is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind) +is_bind decl = Right decl is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) @@ -577,12 +581,12 @@ cvtConstr (InfixC st1 c st2) cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt - ; (dL->L _ con') <- cvtConstr con + ; L _ con' <- cvtConstr con ; returnL $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = Just lcxt - add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2)) - = Just (cL loc (cxt1 ++ cxt2)) + add_cxt (L loc cxt1) (Just (L _ cxt2)) + = Just (L loc (cxt1 ++ cxt2)) add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) @@ -606,7 +610,7 @@ cvtConstr (GadtC [] _strtys _ty) cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys - ; (dL->L _ ty') <- cvtType ty + ; L _ ty' <- cvtType ty ; c_ty <- mk_arr_apps args ty' ; returnL $ fst $ mkGadtDecl c' c_ty} @@ -641,12 +645,12 @@ cvt_arg (Bang su ss, ty) cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) - = do { (dL->L li i') <- vNameL i + = do { L li i' <- vNameL i ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_ext = noExtField , cd_fld_names - = [cL li $ FieldOcc noExtField (cL li i')] + = [L li $ FieldOcc noExtField (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -901,12 +905,14 @@ cvtl e = wrapL (cvt e) -- lambda expressions. See #13856. cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; let pats = map (parenthesizePat appPrec) ps' - ; return $ HsLam noExtField (mkMatchGroup FromSource + ; th_origin <- getOrigin + ; return $ HsLam noExtField (mkMatchGroup th_origin [mkSimpleMatch LambdaExpr pats e'])} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms + ; th_origin <- getOrigin ; return $ HsLamCase noExtField - (mkMatchGroup FromSource ms') + (mkMatchGroup th_origin ms') } cvt (TupE es) = cvt_tup es Boxed cvt (UnboxedTupE es) = cvt_tup es Unboxed @@ -923,8 +929,9 @@ cvtl e = wrapL (cvt e) cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms + ; th_origin <- getOrigin ; return $ HsCase noExtField e' - (mkMatchGroup FromSource ms') } + (mkMatchGroup th_origin ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (MDoE ss) = cvtHsDo MDoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss @@ -1051,7 +1058,7 @@ cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg (map noLoc es') boxity } -{- Note [Operator assocation] +{- Note [Operator association] We must be quite careful about adding parens: * Infix (UInfix ...) op arg Needs parens round the first arg * Infix (Infix ...) op arg Needs parens round the first arg @@ -1124,8 +1131,8 @@ cvtHsDo do_or_lc stmts ; let Just (stmts'', last') = snocView stmts' ; last'' <- case last' of - (dL->L loc (BodyStmt _ body _ _)) - -> return (cL loc (mkLastStmt body)) + (L loc (BodyStmt _ body _ _)) + -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) } @@ -1154,8 +1161,8 @@ cvtMatch :: HsMatchContext RdrName cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of - (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875 - _ -> p' + (L loc SigPat{}) -> L loc (ParPat noExtField p') -- #14875 + _ -> p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) } @@ -1290,10 +1297,10 @@ cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) - = do { (dL->L ls s') <- vNameL s + = do { L ls s' <- vNameL s ; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl - = cL ls $ mkFieldOcc (cL ls s') + = L ls $ mkFieldOcc (L ls s') , hsRecFieldArg = p' , hsRecPun = False}) } @@ -1495,7 +1502,7 @@ cvtTypeKind ty_str ty PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax | Just normals <- m_normals - , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals + , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals -> do returnL (HsExplicitListTy noExtField ip (ty1:tys2)) | otherwise @@ -1568,7 +1575,7 @@ mk_apps head_ty type_args = do go type_args where -- See Note [Adding parens for splices] - add_parens lt@(dL->L _ t) + add_parens lt@(L _ t) | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) | otherwise = return lt @@ -1672,9 +1679,9 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) | null exis, null provs = cvtType (ForallT univs reqs ty) | null univs, null reqs = do { l <- getL ; ty' <- cvtType (ForallT exis provs ty) - ; return $ cL l (HsQualTy { hst_ctxt = cL l [] - , hst_xqual = noExtField - , hst_body = ty' }) } + ; return $ L l (HsQualTy { hst_ctxt = L l [] + , hst_xqual = noExtField + , hst_body = ty' }) } | null reqs = do { l <- getL ; univs' <- hsQTvExplicit <$> cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) @@ -1682,11 +1689,11 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) { hst_fvf = ForallInvis , hst_bndrs = univs' , hst_xforall = noExtField - , hst_body = cL l cxtTy } - cxtTy = HsQualTy { hst_ctxt = cL l [] + , hst_body = L l cxtTy } + cxtTy = HsQualTy { hst_ctxt = L l [] , hst_xqual = noExtField , hst_body = ty' } - ; return $ cL l forTy } + ; return $ L l forTy } | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty = cvtType ty @@ -1745,10 +1752,10 @@ mkHsForAllTy :: [TH.TyVarBndr] -- ^ The complete type, quantified with a forall if necessary mkHsForAllTy tvs loc fvf tvs' rho_ty | null tvs = rho_ty - | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf - , hst_bndrs = hsQTvExplicit tvs' - , hst_xforall = noExtField - , hst_body = rho_ty } + | otherwise = L loc $ HsForAllTy { hst_fvf = fvf + , hst_bndrs = hsQTvExplicit tvs' + , hst_xforall = noExtField + , hst_body = rho_ty } -- | If passed an empty 'TH.Cxt', this simply returns the third argument -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided @@ -1770,9 +1777,9 @@ mkHsQualTy :: TH.Cxt -- ^ The complete type, qualified with a context if necessary mkHsQualTy ctxt loc ctxt' ty | null ctxt = ty - | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField - , hst_ctxt = ctxt' - , hst_body = ty } + | otherwise = L loc $ HsQualTy { hst_xqual = noExtField + , hst_ctxt = ctxt' + , hst_body = ty } -------------------------------------------------------------------- -- Turning Name back into RdrName diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 6e18180d1c..7513e08f82 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -67,9 +67,9 @@ module BasicTypes( isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, strongLoopBreaker, weakLoopBreaker, - InsideLam, insideLam, notInsideLam, - OneBranch, oneBranch, notOneBranch, - InterestingCxt, + InsideLam(..), + OneBranch(..), + InterestingCxt(..), TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, isAlwaysTailCalled, @@ -119,6 +119,7 @@ import SrcLoc ( Located,unLoc ) import Data.Data hiding (Fixity, Prefix, Infix) import Data.Function (on) import Data.Bits +import qualified Data.Semigroup as Semi {- ************************************************************************ @@ -897,7 +898,6 @@ data OccInfo | IAmALoopBreaker { occ_rules_only :: !RulesOnly , occ_tail :: !TailCallInfo } -- Note [LoopBreaker OccInfo] - deriving (Eq) type RulesOnly = Bool @@ -926,25 +926,50 @@ seqOccInfo occ = occ `seq` () ----------------- -- | Interesting Context -type InterestingCxt = Bool -- True <=> Function: is applied - -- Data value: scrutinised by a case with - -- at least one non-DEFAULT branch +data InterestingCxt + = IsInteresting + -- ^ Function: is applied + -- Data value: scrutinised by a case with at least one non-DEFAULT branch + | NotInteresting + deriving (Eq) + +-- | If there is any 'interesting' identifier occurance, then the +-- aggregated occurance info of that identifier is considered interesting. +instance Semi.Semigroup InterestingCxt where + NotInteresting <> x = x + IsInteresting <> _ = IsInteresting + +instance Monoid InterestingCxt where + mempty = NotInteresting + mappend = (Semi.<>) ----------------- -- | Inside Lambda -type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda - -- Substituting a redex for this occurrence is - -- dangerous because it might duplicate work. -insideLam, notInsideLam :: InsideLam -insideLam = True -notInsideLam = False +data InsideLam + = IsInsideLam + -- ^ Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. + | NotInsideLam + deriving (Eq) + +-- | If any occurance of an identifier is inside a lambda, then the +-- occurance info of that identifier marks it as occuring inside a lambda +instance Semi.Semigroup InsideLam where + NotInsideLam <> x = x + IsInsideLam <> _ = IsInsideLam + +instance Monoid InsideLam where + mempty = NotInsideLam + mappend = (Semi.<>) ----------------- -type OneBranch = Bool -- True <=> Occurs in only one case branch - -- so no code-duplication issue to worry about -oneBranch, notOneBranch :: OneBranch -oneBranch = True -notOneBranch = False +data OneBranch + = InOneBranch + -- ^ One syntactic occurance: Occurs in only one case branch + -- so no code-duplication issue to worry about + | MultipleBranches + deriving (Eq) ----------------- data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] @@ -1005,15 +1030,15 @@ instance Outputable OccInfo where pp_ro | rule_only = char '!' | otherwise = empty ppr (OneOcc inside_lam one_branch int_cxt tail_info) - = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail + = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail where - pp_lam | inside_lam = char 'L' - | otherwise = empty - pp_br | one_branch = empty - | otherwise = char '*' - pp_args | int_cxt = char '!' - | otherwise = empty - pp_tail = pprShortTailCallInfo tail_info + pp_lam IsInsideLam = char 'L' + pp_lam NotInsideLam = empty + pp_br MultipleBranches = char '*' + pp_br InOneBranch = empty + pp_args IsInteresting = char '!' + pp_args NotInteresting = empty + pp_tail = pprShortTailCallInfo tail_info pprShortTailCallInfo :: TailCallInfo -> SDoc pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index ee0d2bdccd..2f9a8a1c77 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -618,7 +618,7 @@ useCount _ = Many * * ************************************************************************ -This domain differst from JointDemand in the sence that pure absence +This domain differst from JointDemand in the sense that pure absence is taken away, i.e., we deal *only* with non-absent demands. Note [Strict demands] diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 8c62cc9944..9504175cca 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -559,7 +559,7 @@ idIsFrom mod id = nameIsLocalOrFrom mod (idName id) {- Note [Levity-polymorphic Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some levity-polymorphic Ids must be applied and and inlined, not left +Some levity-polymorphic Ids must be applied and inlined, not left un-saturated. Example: unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index 8a59b98959..dea309de1a 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -54,8 +54,7 @@ module IdInfo ( isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, occInfo, setOccInfo, - InsideLam, OneBranch, - insideLam, notInsideLam, oneBranch, notOneBranch, + InsideLam(..), OneBranch(..), TailCallInfo(..), tailCallInfo, isAlwaysTailCalled, @@ -403,7 +402,7 @@ But we don't do that for instance declarations and so we just treat them all uniformly. The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is -jsut for convenience really. +just for convenience really. However, LocalIds may have non-empty RuleInfo. We treat them differently because: @@ -508,12 +507,12 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) where -- The "unsafe" occ info is the ones that say I'm not in a lambda -- because that might not be true for an unsaturated lambda - is_safe_occ occ | isAlwaysTailCalled occ = False - is_safe_occ (OneOcc { occ_in_lam = in_lam }) = in_lam - is_safe_occ _other = True + is_safe_occ occ | isAlwaysTailCalled occ = False + is_safe_occ (OneOcc { occ_in_lam = NotInsideLam }) = False + is_safe_occ _other = True safe_occ = case occ of - OneOcc{} -> occ { occ_in_lam = True + OneOcc{} -> occ { occ_in_lam = IsInsideLam , occ_tail = NoTailCallInfo } IAmALoopBreaker{} -> occ { occ_tail = NoTailCallInfo } diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index 8a86700bcb..0bfb1f1542 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -180,7 +180,7 @@ They only get converted into real Core, during the CorePrep phase, although TidyPgm looks ahead at what the core will be, so that it can see whether it involves CAFs. -When we initally build an Integer literal, notably when +When we initially build an Integer literal, notably when deserialising it from an interface file (see the Binary instance below), we don't have convenient access to the mkInteger Id. So we just use an error thunk, and fill in the real Id when we do tcIfaceLit diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 56e938ba1b..7ec7839610 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -205,12 +205,6 @@ nameOccName name = n_occ name nameSrcLoc name = srcSpanStart (n_loc name) nameSrcSpan name = n_loc name -type instance SrcSpanLess Name = Name -instance HasSrcSpan Name where - composeSrcSpan (L sp n) = n {n_loc = sp} - decomposeSrcSpan n = L (n_loc n) n - - {- ************************************************************************ * * diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index e69c027173..abe1819dc0 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -527,7 +527,7 @@ parenSymOcc occ doc | isSymOcc occ = parens doc | otherwise = doc startsWithUnderscore :: OccName -> Bool --- ^ Haskell 98 encourages compilers to suppress warnings about unsed +-- ^ Haskell 98 encourages compilers to suppress warnings about unused -- names in a pattern if they start with @_@: this implements that test startsWithUnderscore occ = headFS (occNameFS occ) == '_' diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index bcf2fcbd6e..57915fd666 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -85,9 +85,7 @@ module SrcLoc ( leftmost_smallest, leftmost_largest, rightmost, spans, isSubspanOf, sortLocated, - -- ** HasSrcSpan - HasSrcSpan(..), SrcSpanLess, dL, cL, - pattern LL, onHasSrcSpan, liftL + liftL ) where import GhcPrelude @@ -182,7 +180,7 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) ************************************************************************ -} -sortLocated :: HasSrcSpan a => [a] -> [a] +sortLocated :: [Located a] -> [Located a] sortLocated things = sortBy (comparing getLoc) things instance Outputable RealSrcLoc where @@ -533,36 +531,35 @@ type RealLocated = GenLocated RealSrcSpan mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b mapLoc = fmap -unLoc :: HasSrcSpan a => a -> SrcSpanLess a -unLoc (dL->L _ e) = e +unLoc :: GenLocated l e -> e +unLoc (L _ e) = e -getLoc :: HasSrcSpan a => a -> SrcSpan -getLoc (dL->L l _) = l +getLoc :: GenLocated l e -> l +getLoc (L l _) = l -noLoc :: HasSrcSpan a => SrcSpanLess a -> a -noLoc e = cL noSrcSpan e +noLoc :: e -> Located e +noLoc e = L noSrcSpan e -mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e -mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e +mkGeneralLocated :: String -> e -> Located e +mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e -combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan +combineLocs :: Located a -> Located b -> SrcSpan combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) -- | Combine locations from two 'Located' things and add them to a third thing -addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> SrcSpanLess c -> c -addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c -- not clear whether to add a general Eq instance, but this is useful sometimes: -- | Tests whether the two located things are equal -eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool +eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool eqLocated a b = unLoc a == unLoc b -- not clear whether to add a general Ord instance, but this is useful sometimes: -- | Tests the ordering of the two located things -cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering +cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering cmpLocated a b = unLoc a `compare` unLoc b instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where @@ -604,90 +601,10 @@ isSubspanOf src parent | otherwise = srcSpanStart parent <= srcSpanStart src && srcSpanEnd parent >= srcSpanEnd src - -{- -************************************************************************ -* * -\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans} -* * -************************************************************************ --} - -{- -Note [HasSrcSpan Typeclass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To be able to uniformly set/get source location spans (of `SrcSpan`) in -syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`. -More details can be found at the following wiki page - ImplementingTreesThatGrow/HandlingSourceLocations - -For most syntactic entities, the source location spans are stored in -a syntactic entity by a wapper constuctor (introduced by TTG's -new constructor extension), e.g., by `NewPat (WrapperPat sp pat)` -for a source location span `sp` and a pattern `pat`. --} - --- | Determines the type of undecorated syntactic entities --- For most syntactic entities `E`, where source location spans are --- introduced by a wrapper construtor of the same syntactic entity, --- we have `SrcSpanLess E = E`. --- However, some syntactic entities have a different type compared to --- a syntactic entity `e :: E` may have the type `Located E` when --- decorated by wrapping it with `L sp e` for a source span `sp`. -type family SrcSpanLess a - --- | A typeclass to set/get SrcSpans -class HasSrcSpan a where - -- | Composes a `SrcSpan` decoration with an undecorated syntactic - -- entity to form its decorated variant - composeSrcSpan :: Located (SrcSpanLess a) -> a - - -- | Decomposes a decorated syntactic entity into its `SrcSpan` - -- decoration and its undecorated variant - decomposeSrcSpan :: a -> Located (SrcSpanLess a) - {- laws: - composeSrcSpan . decomposeSrcSpan = id - decomposeSrcSpan . composeSrcSpan = id - - in other words, `HasSrcSpan` defines an iso relation between - a `SrcSpan`-decorated syntactic entity and its undecorated variant - (together with the `SrcSpan`). - -} - -type instance SrcSpanLess (GenLocated l e) = e -instance HasSrcSpan (Located a) where - composeSrcSpan = id - decomposeSrcSpan = id - - --- | An abbreviated form of decomposeSrcSpan, --- mainly to be used in ViewPatterns -dL :: HasSrcSpan a => a -> Located (SrcSpanLess a) -dL = decomposeSrcSpan - --- | An abbreviated form of composeSrcSpan, --- mainly to replace the hardcoded `L` -cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -cL sp e = composeSrcSpan (L sp e) - --- | A Pattern Synonym to Set/Get SrcSpans -pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -pattern LL sp e <- (dL->L sp e) - where - LL sp e = cL sp e - --- | Lifts a function of undecorated entities to one of decorated ones -onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) => - (SrcSpanLess a -> SrcSpanLess b) -> a -> b -onHasSrcSpan f (dL->L l e) = cL l (f e) - -liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) => - (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b -liftL f (dL->L loc a) = do +liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) +liftL f (L loc a) = do a' <- f a - return $ cL loc a' - + return $ L loc a' getRealSrcSpan :: RealLocated a -> RealSrcSpan getRealSrcSpan (L l _) = l diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index 0031074a0b..cbae06d1ca 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -33,8 +33,8 @@ module Unique ( getKey, -- Used in Var, UniqFM, Name only! mkUnique, unpkUnique, -- Used in BinIface only eqUnique, ltUnique, + incrUnique, - deriveUnique, -- Ditto newTagUnique, -- Used in CgCase initTyVarUnique, initExitJoinUnique, @@ -64,7 +64,12 @@ module Unique ( -- *** From TyCon name uniques tyConRepNameUnique, -- *** From DataCon name uniques - dataConWorkerUnique, dataConTyRepNameUnique + dataConWorkerUnique, dataConTyRepNameUnique, + + -- ** Local uniques + -- | These are exposed exclusively for use by 'VarEnv.uniqAway', which + -- has rather peculiar needs. See Note [Local uniques]. + mkLocalUnique, minLocalUnique, maxLocalUnique ) where #include "HsVersions.h" @@ -119,7 +124,6 @@ getKey :: Unique -> Int -- for Var incrUnique :: Unique -> Unique stepUnique :: Unique -> Int -> Unique -deriveUnique :: Unique -> Int -> Unique newTagUnique :: Unique -> Char -> Unique mkUniqueGrimily = MkUnique @@ -130,10 +134,14 @@ getKey (MkUnique x) = x incrUnique (MkUnique i) = MkUnique (i + 1) stepUnique (MkUnique i) n = MkUnique (i + n) --- deriveUnique uses an 'X' tag so that it won't clash with --- any of the uniques produced any other way --- SPJ says: this looks terribly smelly to me! -deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta) +mkLocalUnique :: Int -> Unique +mkLocalUnique i = mkUnique 'X' i + +minLocalUnique :: Unique +minLocalUnique = mkLocalUnique 0 + +maxLocalUnique :: Unique +maxLocalUnique = mkLocalUnique uniqueMask -- newTagUnique changes the "domain" of a unique to a different char newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u @@ -344,7 +352,7 @@ Allocation of unique supply characters: v,t,u : for renumbering value-, type- and usage- vars. B: builtin C-E: pseudo uniques (used in native-code generator) - X: uniques derived by deriveUnique + X: uniques from mkLocalUnique _: unifiable tyvars (above) 0-9: prelude things below (no numbers left any more..) @@ -443,3 +451,4 @@ mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0 + diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index 0daaaea0d1..4c23b1f141 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -54,6 +54,7 @@ module VarEnv ( getInScopeVars, lookupInScope, lookupInScope_Directly, unionInScope, elemInScopeSet, uniqAway, varSetInScope, + unsafeGetFreshLocalUnique, -- * The RnEnv2 type RnEnv2, @@ -74,6 +75,7 @@ module VarEnv ( ) where import GhcPrelude +import qualified Data.IntMap.Strict as IntMap -- TODO: Move this to UniqFM import OccName import Var @@ -97,7 +99,7 @@ import Outputable -- | A set of variables that are in scope at some point -- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides -- the motivation for this abstraction. -data InScopeSet = InScope VarSet {-# UNPACK #-} !Int +newtype InScopeSet = InScope VarSet -- Note [Lookups in in-scope set] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We store a VarSet here, but we use this for lookups rather than just @@ -105,13 +107,9 @@ data InScopeSet = InScope VarSet {-# UNPACK #-} !Int -- version of the variable (e.g. with an informative unfolding), so this -- lookup is useful (see, for instance, Note [In-scope set as a -- substitution]). - -- - -- The Int is a kind of hash-value used by uniqAway - -- For example, it might be the size of the set - -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway instance Outputable InScopeSet where - ppr (InScope s _) = + ppr (InScope s) = text "InScope" <+> braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) -- It's OK to use nonDetEltsUniqSet here because it's @@ -120,76 +118,94 @@ instance Outputable InScopeSet where -- the output is overwhelming emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet 1 +emptyInScopeSet = InScope emptyVarSet getInScopeVars :: InScopeSet -> VarSet -getInScopeVars (InScope vs _) = vs +getInScopeVars (InScope vs) = vs mkInScopeSet :: VarSet -> InScopeSet -mkInScopeSet in_scope = InScope in_scope 1 +mkInScopeSet in_scope = InScope in_scope extendInScopeSet :: InScopeSet -> Var -> InScopeSet -extendInScopeSet (InScope in_scope n) v - = InScope (extendVarSet in_scope v) (n + 1) +extendInScopeSet (InScope in_scope) v + = InScope (extendVarSet in_scope v) extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet -extendInScopeSetList (InScope in_scope n) vs - = InScope (foldl' (\s v -> extendVarSet s v) in_scope vs) - (n + length vs) +extendInScopeSetList (InScope in_scope) vs + = InScope $ foldl' extendVarSet in_scope vs extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet -extendInScopeSetSet (InScope in_scope n) vs - = InScope (in_scope `unionVarSet` vs) (n + sizeUniqSet vs) +extendInScopeSetSet (InScope in_scope) vs + = InScope (in_scope `unionVarSet` vs) delInScopeSet :: InScopeSet -> Var -> InScopeSet -delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarSet` v) n +delInScopeSet (InScope in_scope) v = InScope (in_scope `delVarSet` v) elemInScopeSet :: Var -> InScopeSet -> Bool -elemInScopeSet v (InScope in_scope _) = v `elemVarSet` in_scope +elemInScopeSet v (InScope in_scope) = v `elemVarSet` in_scope -- | Look up a variable the 'InScopeSet'. This lets you map from -- the variable's identity (unique) to its full value. lookupInScope :: InScopeSet -> Var -> Maybe Var -lookupInScope (InScope in_scope _) v = lookupVarSet in_scope v +lookupInScope (InScope in_scope) v = lookupVarSet in_scope v lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var -lookupInScope_Directly (InScope in_scope _) uniq +lookupInScope_Directly (InScope in_scope) uniq = lookupVarSet_Directly in_scope uniq unionInScope :: InScopeSet -> InScopeSet -> InScopeSet -unionInScope (InScope s1 _) (InScope s2 n2) - = InScope (s1 `unionVarSet` s2) n2 +unionInScope (InScope s1) (InScope s2) + = InScope (s1 `unionVarSet` s2) varSetInScope :: VarSet -> InScopeSet -> Bool -varSetInScope vars (InScope s1 _) = vars `subVarSet` s1 +varSetInScope vars (InScope s1) = vars `subVarSet` s1 + +{- +Note [Local uniques] +~~~~~~~~~~~~~~~~~~~~ +Sometimes one must create conjure up a unique which is unique in a particular +context (but not necessarily globally unique). For instance, one might need to +create a fresh local identifier which does not shadow any of the locally +in-scope variables. For this we purpose we provide 'uniqAway'. + +'uniqAway' is implemented in terms of the 'unsafeGetFreshLocalUnique' +operation, which generates an unclaimed 'Unique' from an 'InScopeSet'. To +ensure that we do not conflict with uniques allocated by future allocations +from 'UniqSupply's, Uniques generated by 'unsafeGetFreshLocalUnique' are +allocated into a dedicated region of the unique space (namely the X tag). + +Note that one must be quite carefully when using uniques generated in this way +since they are only locally unique. In particular, two successive calls to +'uniqAway' on the same 'InScopeSet' will produce the same unique. + -} -- | @uniqAway in_scope v@ finds a unique that is not used in the --- in-scope set, and gives that to v. +-- in-scope set, and gives that to v. See Note [Local uniques]. uniqAway :: InScopeSet -> Var -> Var -- It starts with v's current unique, of course, in the hope that it won't --- have to change, and thereafter uses a combination of that and the hash-code --- found in the in-scope set +-- have to change, and thereafter uses the successor to the last derived unique +-- found in the in-scope set. uniqAway in_scope var | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one | otherwise = var -- Nothing to do uniqAway' :: InScopeSet -> Var -> Var -- This one *always* makes up a new variable -uniqAway' (InScope set n) var - = try 1 - where - orig_unique = getUnique var - try k - | debugIsOn && (k > 1000) - = pprPanic "uniqAway loop:" msg - | uniq `elemVarSetByKey` set = try (k + 1) - | k > 3 - = pprTraceDebug "uniqAway:" msg - setVarUnique var uniq - | otherwise = setVarUnique var uniq - where - msg = ppr k <+> text "tries" <+> ppr var <+> int n - uniq = deriveUnique orig_unique (n * k) +uniqAway' in_scope var + = setVarUnique var (unsafeGetFreshLocalUnique in_scope) + +-- | @unsafeGetFreshUnique in_scope@ finds a unique that is not in-scope in the +-- given 'InScopeSet'. This must be used very carefully since one can very easily +-- introduce non-unique 'Unique's this way. See Note [Local uniques]. +unsafeGetFreshLocalUnique :: InScopeSet -> Unique +unsafeGetFreshLocalUnique (InScope set) + | Just (uniq,_) <- IntMap.lookupLT (getKey maxLocalUnique) (ufmToIntMap $ getUniqSet set) + , let uniq' = mkLocalUnique uniq + , not $ uniq' `ltUnique` minLocalUnique + = incrUnique uniq' + + | otherwise + = minLocalUnique {- ************************************************************************ diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs index ec8a325b25..2cf15eb3e5 100644 --- a/compiler/basicTypes/VarSet.hs +++ b/compiler/basicTypes/VarSet.hs @@ -171,7 +171,7 @@ transCloVarSet :: (VarSet -> VarSet) -- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) -- for efficiency, so that the test can be batched up. -- It's essential that fn will work fine if given new candidates --- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 -- Use fixVarSet if the function needs to see the whole set all at once transCloVarSet fn seeds = go seeds seeds @@ -334,7 +334,7 @@ transCloDVarSet :: (DVarSet -> DVarSet) -- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) -- for efficiency, so that the test can be batched up. -- It's essential that fn will work fine if given new candidates --- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 +-- one at a time; ie fn {v1,v2} = fn v1 `union` fn v2 transCloDVarSet fn seeds = go seeds seeds where diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 66e39f0d69..9452b5f6c8 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -348,7 +348,7 @@ data ForeignLabelSource -- external packages. It is safe to treat the RTS package as "external". | ForeignLabelInExternalPackage - -- | Label is in the package currenly being compiled. + -- | Label is in the package currently being compiled. -- This is only used for creating hacky tmp labels during code generation. -- Don't use it in any code that might be inlined across a package boundary -- (ie, core code) else the information will be wrong relative to the diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 9740d21bef..f8b7d4fb74 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -583,6 +583,7 @@ data CallishMachOp | MO_UF_Conv Width + | MO_S_Mul2 Width | MO_S_QuotRem Width | MO_U_QuotRem Width | MO_U_QuotRem2 Width diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index 9d6fa7f29b..1b387020f5 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -669,7 +669,7 @@ scopeUniques (SubScope u _) = [u] scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2 -- Equality and order is based on the head uniques defined above. We --- take care to short-cut the (extremly) common cases. +-- take care to short-cut the (extremely) common cases. instance Eq CmmTickScope where GlobalScope == GlobalScope = True GlobalScope == _ = False diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 3cfb7ecee2..e568378197 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -574,7 +574,7 @@ importName :: { (FastString, CLabel) } -- A label imported without an explicit packageId. - -- These are taken to come frome some foreign, unnamed package. + -- These are taken to come from some foreign, unnamed package. : NAME { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } diff --git a/compiler/cmm/CmmSwitch.hs b/compiler/cmm/CmmSwitch.hs index c2ce3b9e00..a5fa6457e2 100644 --- a/compiler/cmm/CmmSwitch.hs +++ b/compiler/cmm/CmmSwitch.hs @@ -195,7 +195,7 @@ switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches) -- .quad _c20q -- .quad _c20r --- | The list of all labels occuring in the SwitchTargets value. +-- | The list of all labels occurring in the SwitchTargets value. switchTargetsToList :: SwitchTargets -> [Label] switchTargetsToList (SwitchTargets _ _ mbdef branches) = maybeToList mbdef ++ M.elems branches diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 506116c584..d94bc01e03 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -825,6 +825,7 @@ pprCallishMachOp_for_C mop (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) + MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index 7f52054496..fef3915c51 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -210,7 +210,7 @@ exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interestin exprsSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e --- Comment about obselete code +-- Comment about obsolete code -- We used to gather the free variables the RULES at a variable occurrence -- with the following cryptic comment: -- "At a variable occurrence, add in any free variables of its rule rhss diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs index a2eeb9beb8..41a017e8ea 100644 --- a/compiler/coreSyn/CoreOpt.hs +++ b/compiler/coreSyn/CoreOpt.hs @@ -418,11 +418,12 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) -- Unconditionally safe to inline safe_to_inline :: OccInfo -> Bool - safe_to_inline (IAmALoopBreaker {}) = False - safe_to_inline IAmDead = True - safe_to_inline occ@(OneOcc {}) = not (occ_in_lam occ) - && occ_one_br occ - safe_to_inline (ManyOccs {}) = False + safe_to_inline IAmALoopBreaker{} = False + safe_to_inline IAmDead = True + safe_to_inline OneOcc{ occ_in_lam = NotInsideLam + , occ_one_br = InOneBranch } = True + safe_to_inline OneOcc{} = False + safe_to_inline ManyOccs{} = False ------------------- simple_out_bind :: TopLevelFlag @@ -541,7 +542,7 @@ A program has the Let-Unfoldings property iff: - For every let-bound variable f, whether top-level or nested, whether recursive or not: - - Both the binding Id of f, and every occurence Id of f, has an idUnfolding. + - Both the binding Id of f, and every occurrence Id of f, has an idUnfolding. - For non-INLINE things, that unfolding will be f's right hand sids - For INLINE things (which have a "stable" unfolding) that unfolding is semantically equivalent to f's RHS, but derived from the original RHS of f @@ -1225,11 +1226,11 @@ Here we implement the "push rules" from FC papers: (fun |> co) arg and we want to transform it to (fun arg') |> co' - for some suitable co' and tranformed arg'. + for some suitable co' and transformed arg'. * The PushK rule for data constructors. We have (K e1 .. en) |> co - and we want to tranform to + and we want to transform to (K e1' .. en') by pushing the coercion into the arguments -} diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 797648236f..e7ebaaea95 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -1227,7 +1227,7 @@ notOrphan _ = False chooseOrphanAnchor :: NameSet -> IsOrphan -- Something (rule, instance) is relate to all the Names in this -- list. Choose one of them to be an "anchor" for the orphan. We make --- the choice deterministic to avoid gratuitious changes in the ABI +-- the choice deterministic to avoid gratuitous changes in the ABI -- hash (#4012). Specifically, use lexicographic comparison of -- OccName rather than comparing Uniques -- @@ -1559,7 +1559,7 @@ data UnfoldingGuidance ug_size :: Int, -- The "size" of the unfolding. - ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in + ug_res :: Int -- Scrutinee discount: the discount to subtract if the thing is in } -- a context (case (thing args) of ...), -- (where there are the right number of arguments.) diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 6dd6d37a9a..8a823906af 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -121,7 +121,7 @@ guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead. - let top_pos = catMaybes $ foldr (\ (dL->L pos _) rest -> + let top_pos = catMaybes $ foldr (\ (L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds in case top_pos of @@ -255,12 +255,12 @@ addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) addTickLHsBinds = mapBagM addTickLHsBind addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) -addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds, +addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, abs_exports = abs_exports })) = do withEnv add_exports $ do withEnv add_inlines $ do binds' <- addTickLHsBinds binds - return $ cL pos $ bind { abs_binds = binds' } + return $ L pos $ bind { abs_binds = binds' } where -- in AbsBinds, the Id on each binding is not the actual top-level -- Id that we are defining, they are related by the abs_exports @@ -280,7 +280,7 @@ addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds = binds, | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , isInlinePragma (idInlinePragma pid) ] } -addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do +addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity @@ -292,7 +292,7 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do -- See Note [inline sccs] tickish <- tickishType `liftM` getEnv - if inline && tickish == ProfNotes then return (cL pos funBind) else do + if inline && tickish == ProfNotes then return (L pos funBind) else do (fvs, mg) <- getFreeVars $ @@ -321,8 +321,8 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do return Nothing let mbCons = maybe Prelude.id (:) - return $ cL pos $ funBind { fun_matches = mg - , fun_tick = tick `mbCons` fun_tick funBind } + return $ L pos $ funBind { fun_matches = mg + , fun_tick = tick `mbCons` fun_tick funBind } where -- a binding is a simple pattern binding if it is a funbind with @@ -331,8 +331,8 @@ addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id) }))) = do isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 -- TODO: Revisit this -addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs - , pat_rhs = rhs }))) = do +addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs + , pat_rhs = rhs }))) = do let name = "(...)" (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs let pat' = pat { pat_rhs = rhs'} @@ -342,7 +342,7 @@ addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs decl_path <- getPathEntry let top_lev = null decl_path if not (shouldTickPatBind density top_lev) - then return (cL pos pat') + then return (L pos pat') else do -- Allocate the ticks @@ -355,14 +355,12 @@ addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat') patvar_tickss = zipWith mbCons patvar_ticks (snd (pat_ticks pat') ++ repeat []) - return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } + return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } -- Only internal stuff, not from source, uses VarBind, so we ignore it. -addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind -addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind -addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind -addTickLHsBind _ = panic "addTickLHsBind: Impossible Match" -- due to #15884 - +addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind +addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind bindTick @@ -397,7 +395,7 @@ bindTick density name pos fvs = do -- selectively add ticks to interesting expressions addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExpr e@(dL->L pos e0) = do +addTickLHsExpr e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it @@ -413,7 +411,7 @@ addTickLHsExpr e@(dL->L pos e0) = do -- (because the body will definitely have a tick somewhere). ToDo: perhaps -- we should treat 'case' and 'if' the same way? addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprRHS e@(dL->L pos e0) = do +addTickLHsExprRHS e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it @@ -442,7 +440,7 @@ addTickLHsExprEvalInner e = do -- break012. This gives the user the opportunity to inspect the -- values of the let-bound variables. addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprLetBody e@(dL->L pos e0) = do +addTickLHsExprLetBody e@(L pos e0) = do d <- getDensity case d of TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it @@ -456,9 +454,9 @@ addTickLHsExprLetBody e@(dL->L pos e0) = do -- because the scope of this tick is completely subsumed by -- another. addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprNever (dL->L pos e0) = do +addTickLHsExprNever (L pos e0) = do e1 <- addTickHsExpr e0 - return $ cL pos e1 + return $ L pos e1 -- general heuristic: expressions which do not denote values are good -- break points @@ -475,16 +473,16 @@ isCallSite OpApp{} = True isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprOptAlt oneOfMany (dL->L pos e0) +addTickLHsExprOptAlt oneOfMany (L pos e0) = ifDensity TickForCoverage (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) - (addTickLHsExpr (cL pos e0)) + (addTickLHsExpr (L pos e0)) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addBinTickLHsExpr boxLabel (dL->L pos e0) +addBinTickLHsExpr boxLabel (L pos e0) = ifDensity TickForCoverage (allocBinTickBox boxLabel pos $ addTickHsExpr e0) - (addTickLHsExpr (cL pos e0)) + (addTickLHsExpr (L pos e0)) -- ----------------------------------------------------------------------------- @@ -493,7 +491,7 @@ addBinTickLHsExpr boxLabel (dL->L pos e0) -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e +addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr e@(HsConLikeOut _ con) | Just id <- conLikeWrapId_maybe con = do freeVar id; return e @@ -552,14 +550,14 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x (dL->L l binds) e) = +addTickHsExpr (HsLet x (L l binds) e) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsLet x . cL l) + liftM2 (HsLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) -addTickHsExpr (HsDo srcloc cxt (dL->L l stmts)) +addTickHsExpr (HsDo srcloc cxt (L l stmts)) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo srcloc cxt (cL l stmts')) } + ; return (HsDo srcloc cxt (L l stmts')) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -606,20 +604,12 @@ addTickHsExpr (HsTick x t e) = addTickHsExpr (HsBinTick x t0 t1 e) = liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do +addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 return $ unLoc e2 -addTickHsExpr (HsSCC x src nm e) = - liftM3 (HsSCC x) - (return src) - (return nm) - (addTickLHsExpr e) -addTickHsExpr (HsCoreAnn x src nm e) = - liftM3 (HsCoreAnn x) - (return src) - (return nm) - (addTickLHsExpr e) +addTickHsExpr (HsPragE x p e) = + liftM (HsPragE x p) (addTickLHsExpr e) addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e @@ -637,19 +627,18 @@ addTickHsExpr (HsWrap x w e) = addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (dL->L l (Present x e)) = do { e' <- addTickLHsExpr e - ; return (cL l (Present x e')) } -addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty)) -addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec -addTickTupArg _ = panic "addTickTupArg: Impossible Match" -- due to #15884 +addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e + ; return (L l (Present x e')) } +addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) +addTickTupArg (L _ (XTupArg nec)) = noExtCon nec addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do +addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do let isOneOfMany = matchesOneOfMany matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches - return $ mg { mg_alts = cL l matches' } + return $ mg { mg_alts = L l matches' } addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) @@ -663,11 +652,11 @@ addTickMatch _ _ (XMatch nec) = noExtCon nec addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs x guarded' (cL l local_binds') + return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec @@ -681,7 +670,7 @@ addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do addTickGRHS _ _ (XGRHS nec) = noExtCon nec addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do +addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do d <- getDensity case d of TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr @@ -724,13 +713,13 @@ addTickStmt isGuard (BodyStmt x e bind' guard') = do (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do - liftM (LetStmt x . cL l) +addTickStmt _isGuard (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs) - (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr)) + (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do args' <- mapM (addTickApplicativeArg isGuard) args @@ -745,7 +734,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr)) + t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr)) return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } @@ -778,7 +767,7 @@ addTickApplicativeArg isGuard (op, arg) = addTickArg (ApplicativeArgMany x stmts ret pat) = (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret)) + <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) <*> addTickLPat pat addTickArg (XApplicativeArg nec) = noExtCon nec @@ -831,7 +820,7 @@ addTickIPBind (XIPBind x) = return (XIPBind x) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do - x' <- fmap unLoc (addTickLHsExpr (cL pos x)) + x' <- fmap unLoc (addTickLHsExpr (L pos x)) return $ syn { syn_expr = x' } -- we do not walk into patterns. addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) @@ -845,9 +834,9 @@ addTickHsCmdTop (HsCmdTop x cmd) = addTickHsCmdTop (XCmdTop nec) = noExtCon nec addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) -addTickLHsCmd (dL->L pos c0) = do +addTickLHsCmd (L pos c0) = do c1 <- addTickHsCmd c0 - return $ cL pos c1 + return $ L pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) addTickHsCmd (HsCmdLam x matchgroup) = @@ -872,14 +861,14 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x (dL->L l binds) c) = +addTickHsCmd (HsCmdLet x (L l binds) c) = bindLocals (collectLocalBinders binds) $ - liftM2 (HsCmdLet x . cL l) + liftM2 (HsCmdLet x . L l) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsCmdDo srcloc (dL->L l stmts)) +addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo srcloc (cL l stmts')) } + ; return (HsCmdDo srcloc (L l stmts')) } addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = liftM5 HsCmdArrApp @@ -905,9 +894,9 @@ addTickHsCmd (XCmd nec) = noExtCon nec addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) -addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do +addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do matches' <- mapM (liftL addTickCmdMatch) matches - return $ mg { mg_alts = cL l matches' } + return $ mg { mg_alts = L l matches' } addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) @@ -918,11 +907,11 @@ addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = addTickCmdMatch (XMatch nec) = noExtCon nec addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do +addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs x guarded' (cL l local_binds') + return $ GRHSs x guarded' (L l local_binds') where binders = collectLocalBinders local_binds addTickCmdGRHSs (XGRHSs nec) = noExtCon nec @@ -969,8 +958,8 @@ addTickCmdStmt (BodyStmt x c bind' guard') = do (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickCmdStmt (LetStmt x (dL->L l binds)) = do - liftM (LetStmt x . cL l) +addTickCmdStmt (LetStmt x (L l binds)) = do + liftM (LetStmt x . L l) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) @@ -994,9 +983,9 @@ addTickHsRecordBinds (HsRecFields fields dd) addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) -> TM (LHsRecField' id (LHsExpr GhcTc)) -addTickHsRecField (dL->L l (HsRecField id expr pun)) +addTickHsRecField (L l (HsRecField id expr pun)) = do { expr' <- addTickLHsExpr expr - ; return (cL l (HsRecField id expr' pun)) } + ; return (L l (HsRecField id expr' pun)) } addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) @@ -1176,10 +1165,10 @@ allocTickBox boxLabel countEntries topOnly pos m = (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (cL pos (HsTick noExtField tickish (cL pos e))) + return (L pos (HsTick noExtField tickish (L pos e))) ) (do e <- m - return (cL pos e) + return (L pos e) ) -- the tick application inherits the source position of its @@ -1247,7 +1236,7 @@ allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) allocBinTickBox boxLabel pos m = do env <- getEnv case tickishType env of - HpcTicks -> do e <- liftM (cL pos) m + HpcTicks -> do e <- liftM (L pos) m ifGoodTickSrcSpan pos (mkBinTickBoxHpc boxLabel pos e) (return e) @@ -1263,8 +1252,8 @@ mkBinTickBoxHpc boxLabel pos e = c = tickBoxCount st mes = mixEntries st in - ( cL pos $ HsTick noExtField (HpcTick (this_mod env) c) - $ cL pos $ HsBinTick noExtField (c+1) (c+2) e + ( L pos $ HsTick noExtField (HpcTick (this_mod env) c) + $ L pos $ HsBinTick noExtField (c+1) (c+2) e -- notice that F and T are reversed, -- because we are building the list in -- reverse... @@ -1291,12 +1280,11 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") matchesOneOfMany :: [LMatch GhcTc body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where - matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ })) + matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss - matchCount (dL->L _ (Match { m_grhss = XGRHSs nec })) + matchCount (L _ (Match { m_grhss = XGRHSs nec })) = noExtCon nec - matchCount (dL->L _ (XMatch nec)) = noExtCon nec - matchCount _ = panic "matchCount: Impossible Match" -- due to #15884 + matchCount (L _ (XMatch nec)) = noExtCon nec type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 5ecc4da00e..f5aa6f0785 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -369,13 +369,13 @@ Reason -} dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) -dsRule (dL->L loc (HsRule { rd_name = name - , rd_act = rule_act - , rd_tmvs = vars - , rd_lhs = lhs - , rd_rhs = rhs })) +dsRule (L loc (HsRule { rd_name = name + , rd_act = rule_act + , rd_tmvs = vars + , rd_lhs = lhs + , rd_rhs = rhs })) = putSrcSpanDs loc $ - do { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars] + do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ unsetWOptM Opt_WarnIdentities $ @@ -412,8 +412,7 @@ dsRule (dL->L loc (HsRule { rd_name = name ; return (Just rule) } } } -dsRule (dL->L _ (XRuleDecl nec)) = noExtCon nec -dsRule _ = panic "dsRule: Impossible Match" -- due to #15884 +dsRule (L _ (XRuleDecl nec)) = noExtCon nec warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () -- See Note [Rules and inlining/other rules] @@ -528,7 +527,7 @@ In the above example, suppose we had {-# RULES "rule-for-g" forally. g [y] = ... #-} Then "rule-for-f" and "rule-for-g" would compete. Better to add phase control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes -active; or perhpas after "rule-for-g" has become inactive. This is checked +active; or perhaps after "rule-for-g" has become inactive. This is checked by 'competesWith' Class methods have a built-in RULE to select the method from the dictionary, diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index ade017208d..0cbf3dae39 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -316,7 +316,7 @@ dsProcExpr :: LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr -dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do +dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do (meth_binds, meth_ids) <- mkCmdEnv ids let locals = mkVarSet (collectPatBinders pat) (core_cmd, _free_vars, env_ids) @@ -455,8 +455,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do dsCmd ids local_vars stack_ty res_ty (HsCmdLam _ (MG { mg_alts - = (dL->L _ [dL->L _ (Match { m_pats = pats - , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) })) + = (L _ [L _ (Match { m_pats = pats + , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) let @@ -567,7 +567,7 @@ case bodies, containing the following fields: -} dsCmd ids local_vars stack_ty res_ty - (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches) + (HsCmdCase _ exp (MG { mg_alts = L l matches , mg_ext = MatchGroupTc arg_tys _ , mg_origin = origin })) env_ids = do @@ -616,7 +616,7 @@ dsCmd ids local_vars stack_ty res_ty in_ty = envStackType env_ids stack_ty core_body <- dsExpr (HsCase noExtField exp - (MG { mg_alts = cL l matches' + (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc arg_tys sum_ty , mg_origin = origin })) -- Note that we replace the HsCase result type by sum_ty, @@ -632,7 +632,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body) +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) @@ -660,7 +660,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body) -- ---> premap (\ (env,stk) -> env) c dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty - (dL->L loc stmts)) + (L loc stmts)) env_ids = do putSrcSpanDs loc $ dsNoLevPoly stmts_ty @@ -706,7 +706,7 @@ dsTrimCmdArg -> DsM (CoreExpr, -- desugared expression DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids - (dL->L _ (HsCmdTop + (L _ (HsCmdTop (CmdTopTc stack_ty cmd_ty ids) cmd )) = do (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') @@ -778,7 +778,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -- -- ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do +dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do putSrcSpanDs loc $ dsNoLevPoly res_ty (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids @@ -1139,8 +1139,8 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" leavesMatch :: LMatch GhcTc (Located (body GhcTc)) -> [(Located (body GhcTc), IdSet)] -leavesMatch (dL->L _ (Match { m_pats = pats - , m_grhss = GRHSs _ grhss (dL->L _ binds) })) +leavesMatch (L _ (Match { m_pats = pats + , m_grhss = GRHSs _ grhss (L _ binds) })) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` @@ -1149,7 +1149,7 @@ leavesMatch (dL->L _ (Match { m_pats = pats [(body, mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) - | (dL->L _ (GRHS _ stmts body)) <- grhss] + | L _ (GRHS _ stmts body) <- grhss] leavesMatch _ = panic "leavesMatch" -- Replace the leaf commands in a match @@ -1161,12 +1161,12 @@ replaceLeavesMatch -> ([Located (body' GhcTc)], -- remaining leaf expressions LMatch GhcTc (Located (body' GhcTc))) -- updated match replaceLeavesMatch _res_ty leaves - (dL->L loc + (L loc match@(Match { m_grhss = GRHSs x grhss binds })) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', cL loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) + (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch" replaceLeavesGRHS @@ -1174,8 +1174,8 @@ replaceLeavesGRHS -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command -> ([Located (body' GhcTc)], -- remaining leaf expressions LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _)) - = (leaves, cL loc (GRHS x stmts leaf)) +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) + = (leaves, L loc (GRHS x stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS" @@ -1221,14 +1221,14 @@ collectPatsBinders pats = foldr collectl [] pats --------------------- collectl :: LPat GhcTc -> [Id] -> [Id] -- See Note [Dictionary binders in ConPatOut] -collectl (dL->L _ pat) bndrs +collectl (L _ pat) bndrs = go pat where - go (VarPat _ (dL->L _ var)) = var : bndrs + go (VarPat _ (L _ var)) = var : bndrs go (WildPat _) = bndrs go (LazyPat _ pat) = collectl pat bndrs go (BangPat _ pat) = collectl pat bndrs - go (AsPat _ (dL->L _ a) pat) = a : collectl pat bndrs + go (AsPat _ (L _ a) pat) = a : collectl pat bndrs go (ParPat _ pat) = collectl pat bndrs go (ListPat _ pats) = foldr collectl bndrs pats @@ -1241,7 +1241,7 @@ collectl (dL->L _ pat) bndrs ++ foldr collectl bndrs (hsConPatArgs ps) go (LitPat _ _) = bndrs go (NPat {}) = bndrs - go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs + go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs go (SigPat _ pat _) = collectl pat bndrs go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 20a3b23e96..dbfc6f52fd 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -101,7 +101,7 @@ dsTopLHsBinds binds unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds bang_binds = filterBag (isBangedHsBind . unLoc) binds - top_level_err desc (dL->L loc bind) + top_level_err desc (L loc bind) = putSrcSpanDs loc $ errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)) @@ -118,8 +118,8 @@ dsLHsBinds binds ------------------------ dsLHsBind :: LHsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags - putSrcSpanDs loc $ dsHsBind dflags bind +dsLHsBind (L loc bind) = do dflags <- getDynFlags + putSrcSpanDs loc $ dsHsBind dflags bind -- | Desugar a single binding (or group of recursive binds). dsHsBind :: DynFlags @@ -143,7 +143,7 @@ dsHsBind dflags (VarBind { var_id = var else [] ; return (force_var, [core_bind]) } -dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun) +dsHsBind dflags b@(FunBind { fun_id = L _ fun , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick }) @@ -657,7 +657,7 @@ dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding -- rhs is in the Id's unfolding -> Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) -dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl)) +dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | isJust (isClassOpId_maybe poly_id) = putSrcSpanDs loc $ do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector" diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index d0409ffd71..e58bb341aa 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -72,11 +72,11 @@ import Control.Monad -} dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsLocalBinds (dL->L _ (EmptyLocalBinds _)) body = return body -dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (dL->L _ (HsIPBinds _ binds)) body = dsIPBinds binds body -dsLocalBinds _ _ = panic "dsLocalBinds" +dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body +dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ + dsValBinds binds body +dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body +dsLocalBinds _ _ = panic "dsLocalBinds" ------------------------- -- caller sets location @@ -94,7 +94,7 @@ dsIPBinds (IPBinds ev_binds ip_binds) body -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where - ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body + ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) ds_ip_bind _ _ = panic "dsIPBinds" @@ -108,7 +108,7 @@ ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [dL->L loc bind] <- bagToList hsbinds + | [L loc bind] <- bagToList hsbinds -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes @@ -192,13 +192,13 @@ dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] ; ds_binds <- dsTcEvBinds_s ev_binds ; return (mkCoreLets ds_binds body2) } -dsUnliftedBind (FunBind { fun_id = (dL->L l fun) +dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches , fun_co_fn = co_fn , fun_tick = tick }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed - = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun)) + = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches ; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( isIdHsWrapper co_fn ) @@ -231,7 +231,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (dL->L loc e) +dsLExpr (L loc e) = putSrcSpanDs loc $ do { core_expr <- dsExpr e -- uncomment this check to test the hsExprType function in TcHsSyn @@ -246,7 +246,7 @@ dsLExpr (dL->L loc e) -- See Note [Levity polymorphism checking] in DsMonad -- See Note [Levity polymorphism invariants] in CoreSyn dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr -dsLExprNoLP (dL->L loc e) +dsLExprNoLP (L loc e) = putSrcSpanDs loc $ do { e' <- dsExpr e ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) @@ -260,7 +260,7 @@ ds_expr :: Bool -- are we directly inside an HsWrap? -> HsExpr GhcTc -> DsM CoreExpr ds_expr _ (HsPar _ e) = dsLExpr e ds_expr _ (ExprWithTySig _ e _) = dsLExpr e -ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var +ds_expr w (HsVar _ (L _ var)) = dsHsVar w var ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them ds_expr w (HsConLikeOut _ con) = dsConLike w con ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar" @@ -285,7 +285,7 @@ ds_expr _ (HsWrap _ co_fn e) ; warnAboutIdentities dflags e' wrapped_ty ; return wrapped_e } -ds_expr _ (NegApp _ (dL->L loc +ds_expr _ (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) neg_expr) = do { expr' <- putSrcSpanDs loc $ do @@ -377,12 +377,12 @@ ds_expr _ e@(SectionR _ op expr) = do core_op [Var x_id, Var y_id])) ds_expr _ (ExplicitTuple _ tup_args boxity) - = do { let go (lam_vars, args) (dL->L _ (Missing ty)) + = do { let go (lam_vars, args) (L _ (Missing ty)) -- For every missing expression, we need -- another lambda in the desugaring. = do { lam_var <- newSysLocalDsNoLP ty ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (dL->L _ (Present _ expr)) + go (lam_vars, args) (L _ (Present _ expr)) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr @@ -402,20 +402,8 @@ ds_expr _ (ExplicitSum types alt arity expr) map Type types ++ [core_expr]) ) } -ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do - dflags <- getDynFlags - if gopt Opt_SccProfilingOn dflags - then do - mod_name <- getModule - count <- goptM Opt_ProfCountEntries - let nm = sl_fs cc - flavour <- ExprCC <$> getCCIndexM nm - Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True) - <$> dsLExpr expr - else dsLExpr expr - -ds_expr _ (HsCoreAnn _ _ _ expr) - = dsLExpr expr +ds_expr _ (HsPragE _ prag expr) = + ds_prag_expr prag expr ds_expr _ (HsCase _ discrim matches) = do { core_discrim <- dsLExpr discrim @@ -431,11 +419,11 @@ ds_expr _ (HsLet _ binds body) = do -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty -ds_expr _ (HsDo _ DoExpr (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ GhciStmtCtxt (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MDoExpr (dL->L _ stmts)) = dsDo stmts -ds_expr _ (HsDo _ MonadComp (dL->L _ stmts)) = dsMonadComp stmts +ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty +ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts +ds_expr _ (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -485,7 +473,7 @@ See Note [Grand plan for static forms] in StaticPtrTable for an overview. g = ... makeStatic loc f ... -} -ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do +ds_expr _ (HsStatic _ expr@(L loc _)) = do expr_ds <- dsLExprNoLP expr let ty = exprType expr_ds makeStaticId <- dsLookupGlobalId makeStaticName @@ -624,7 +612,7 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields -- of the record selector, and we must not make that a local binder -- else we shadow other uses of the record selector -- Hence 'lcl_id'. Cf #2735 - ds_field (dL->L _ rec_field) + ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field) ; let fld_id = unLoc (hsRecUpdFieldId rec_field) ; lcl_id <- newSysLocalDs (idType fld_id) @@ -745,18 +733,32 @@ ds_expr _ (HsBinTick _ ixT ixF e) = do mkBinaryTickBox ixT ixF e2 } -ds_expr _ (HsTickPragma _ _ _ _ expr) = do - dflags <- getDynFlags - if gopt Opt_Hpc dflags - then panic "dsExpr:HsTickPragma" - else dsLExpr expr - -- HsSyn constructs that just shouldn't be here: ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_expr _ (XExpr nec) = noExtCon nec +ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr +ds_prag_expr (HsPragSCC _ _ cc) expr = do + dflags <- getDynFlags + if gopt Opt_SccProfilingOn dflags + then do + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + let nm = sl_fs cc + flavour <- ExprCC <$> getCCIndexM nm + Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) + <$> dsLExpr expr + else dsLExpr expr +ds_prag_expr (HsPragCore _ _ _) expr + = dsLExpr expr +ds_prag_expr (HsPragTick _ _ _ _) expr = do + dflags <- getDynFlags + if gopt Opt_Hpc dflags + then panic "dsExpr:HsPragTick" + else dsLExpr expr +ds_prag_expr (XHsPragE x) _ = noExtCon x ------------------------------ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr @@ -775,7 +777,7 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel - = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds + = [hsRecFieldArg fld | L _ fld <- rbinds , sel == idName (unLoc $ hsRecFieldId fld) ] {- @@ -894,7 +896,7 @@ dsDo stmts = goL stmts where goL [] = panic "dsDo" - goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) go _ (LastStmt _ body _ _) stmts = ASSERT( null stmts ) dsLExpr body @@ -959,7 +961,7 @@ dsDo stmts , recS_ret_ty = body_ty} }) stmts = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where - new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) + new_bind_stmt = L loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail @@ -1000,7 +1002,7 @@ handle_failure pat match fail_op | otherwise = extractMatchResult match (error "It can't fail") -mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String +mk_fail_msg :: DynFlags -> Located e -> String mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ showPpr dflags (getLoc pat) @@ -1140,7 +1142,7 @@ we're not directly in an HsWrap, reject. checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () checkForcedEtaExpansion expr ty | Just var <- case expr of - HsVar _ (dL->L _ var) -> Just var + HsVar _ (L _ var) -> Just var HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) _ -> Nothing , let bad_tys = badUseOfLevPolyPrimop var ty diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 43ef2327c5..49dab953bf 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -97,7 +97,7 @@ dsForeigns' fos = do (vcat cs $$ vcat fe_init_code), foldr (appOL . toOL) nilOL bindss) where - do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl) + do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) @@ -106,10 +106,10 @@ dsForeigns' fos = do traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) - do_decl (ForeignExport { fd_name = (dL->L _ id) + do_decl (ForeignExport { fd_name = L _ id , fd_e_ext = co , fd_fe = CExport - (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do + (L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) do_decl (XForeignDecl nec) = noExtCon nec diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index a6ef106c98..fe60cb8001 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -70,10 +70,9 @@ dsGRHSs _ (XGRHSs nec) _ = noExtCon nec dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM MatchResult -dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs)) +dsGRHS hs_ctx rhs_ty (L _ (GRHS _ guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty -dsGRHS _ _ (dL->L _ (XGRHS nec)) = noExtCon nec -dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884 +dsGRHS _ _ (L _ (XGRHS nec)) = noExtCon nec {- ************************************************************************ diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index e826045eb5..084a9dabff 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -484,8 +484,8 @@ dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMonadComp stmts = dsMcStmts stmts dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr -dsMcStmts [] = panic "dsMcStmts" -dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) --------------- dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr @@ -639,7 +639,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts | otherwise = extractMatchResult match (error "It can't fail") - mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String + mk_fail_msg :: DynFlags -> Located e -> String mk_fail_msg dflags pat = "Pattern match failure in monad comprehension at " ++ showPpr dflags (getLoc pat) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 5290d1a978..0b0c7abdb4 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -170,15 +170,15 @@ repTopDs group@(HsGroup { hs_valds = valds wrapGenSyms ss q_decs } where - no_splice (dL->L loc _) + no_splice (L loc _) = notHandledL loc "Splices within declaration brackets" empty - no_default_decl (dL->L loc decl) + no_default_decl (L loc decl) = notHandledL loc "Default declarations" (ppr decl) - no_warn (dL->L loc (Warning _ thing _)) + no_warn (L loc (Warning _ thing _)) = notHandledL loc "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing no_warn _ = panic "repTopDs" - no_doc (dL->L loc _) + no_doc (L loc _) = notHandledL loc "Haddock documentation" empty repTopDs (XHsGroup nec) = noExtCon nec @@ -192,7 +192,7 @@ hsScopedTvBinders binds XValBindsLR (NValBinds _ sigs) -> sigs get_scoped_tvs :: LSig GhcRn -> [Name] -get_scoped_tvs (dL->L _ signature) +get_scoped_tvs (L _ signature) | TypeSig _ _ sig <- signature = get_scoped_tvs_from_sig (hswc_body sig) | ClassOpSig _ _ _ sig <- signature @@ -279,7 +279,7 @@ in repTyClD and repC. Note [Don't quantify implicit type variables in quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you're not careful, it's suprisingly easy to take this quoted declaration: +If you're not careful, it's surprisingly easy to take this quoted declaration: [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b idProxy x = x @@ -302,24 +302,24 @@ them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. -- repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $ - repFamilyDecl (L loc fam) +repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ + repFamilyDecl (L loc fam) -repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) +repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repSynDecl tc1 bndrs rhs ; return (Just (loc, dec)) } -repTyClD (dL->L loc (DataDecl { tcdLName = tc - , tcdTyVars = tvs - , tcdDataDefn = defn })) +repTyClD (L loc (DataDecl { tcdLName = tc + , tcdTyVars = tvs + , tcdDataDefn = defn })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repDataDefn tc1 (Left bndrs) defn ; return (Just (loc, dec)) } -repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = fds, tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = atds })) @@ -341,7 +341,7 @@ repTyClD _ = panic "repTyClD" ------------------------- repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles)) +repRoleD (L loc (RoleAnnotDecl _ tycon roles)) = do { tycon1 <- lookupLOcc tycon ; roles1 <- mapM repRole roles ; roles2 <- coreList roleTyConName roles1 @@ -351,7 +351,7 @@ repRoleD _ = panic "repRoleD" ------------------------- repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repKiSigD (dL->L loc kisig) = +repKiSigD (L loc kisig) = case kisig of StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v XStandaloneKindSig nec -> noExtCon nec @@ -393,11 +393,11 @@ repSynDecl tc bndrs ty ; repTySyn tc bndrs ty1 } repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo = info - , fdLName = tc - , fdTyVars = tvs - , fdResultSig = dL->L _ resultSig - , fdInjectivityAnn = injectivity })) +repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info + , fdLName = tc + , fdTyVars = tvs + , fdResultSig = L _ resultSig + , fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_ext = [] @@ -453,7 +453,7 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> DsM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = do { coreNothing injAnnTyConName } -repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) = +repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = do { lhs' <- lookupBinder (unLoc lhs) ; rhs1 <- mapM (lookupBinder . unLoc) rhs ; rhs2 <- coreList nameTyConName rhs1 @@ -473,7 +473,7 @@ repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep]) repLFunDeps fds = repList funDepTyConName repLFunDep fds repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep) -repLFunDep (dL->L _ (xs, ys)) +repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs ys' <- repList nameTyConName (lookupBinder . unLoc) ys repFunDep xs' ys' @@ -481,13 +481,13 @@ repLFunDep (dL->L _ (xs, ys)) -- Represent instance declarations -- repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl })) +repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) = do { dec <- repTyFamInstD fi_decl ; return (loc, dec) } -repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl })) +repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) = do { dec <- repDataFamInstD fi_decl ; return (loc, dec) } -repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl })) +repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl ; return (loc, dec) } repInstD _ = panic "repInstD" @@ -523,8 +523,8 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds repClsInstD (XClsInstDecl nec) = noExtCon nec repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat - , deriv_type = ty })) +repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat + , deriv_type = ty })) = do { dec <- addSimpleTyVarBinds tvs $ do { cxt' <- repLContext cxt ; strat' <- repDerivStrategy strat @@ -611,9 +611,8 @@ repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) -repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ - , fd_fi = CImport (dL->L _ cc) - (dL->L _ s) mch cis _ })) +repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ + , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) = do MkC name' <- lookupLOcc name MkC typ' <- repHsSigType typ MkC cc' <- repCCallConv cc @@ -654,7 +653,7 @@ repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir))) +repFixD (L loc (FixitySig _ names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of InfixL -> infixLDName @@ -668,12 +667,12 @@ repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir))) repFixD _ = panic "repFixD" repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repRuleD (dL->L loc (HsRule { rd_name = n - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs })) +repRuleD (L loc (HsRule { rd_name = n + , rd_act = act + , rd_tyvs = ty_bndrs + , rd_tmvs = tm_bndrs + , rd_lhs = lhs + , rd_rhs = rhs })) = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs ; ss <- mkGenSyms tm_bndr_names @@ -695,29 +694,28 @@ repRuleD (dL->L loc (HsRule { rd_name = n repRuleD _ = panic "repRuleD" ruleBndrNames :: LRuleBndr GhcRn -> [Name] -ruleBndrNames (dL->L _ (RuleBndr _ n)) = [unLoc n] -ruleBndrNames (dL->L _ (RuleBndrSig _ n sig)) +ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] +ruleBndrNames (L _ (RuleBndrSig _ n sig)) | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig = unLoc n : vars -ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) +ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) = panic "ruleBndrNames" -ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) +ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) = panic "ruleBndrNames" -ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec -ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884 +ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) -repRuleBndr (dL->L _ (RuleBndr _ n)) +repRuleBndr (L _ (RuleBndr _ n)) = do { MkC n' <- lookupLBinder n ; rep2 ruleVarName [n'] } -repRuleBndr (dL->L _ (RuleBndrSig _ n sig)) +repRuleBndr (L _ (RuleBndrSig _ n sig)) = do { MkC n' <- lookupLBinder n ; MkC ty' <- repLTy (hsSigWcType sig) ; rep2 typedRuleVarName [n', ty'] } repRuleBndr _ = panic "repRuleBndr" repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) -repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp))) +repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp' @@ -725,10 +723,10 @@ repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp))) repAnnD _ = panic "repAnnD" repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) -repAnnProv (ValueAnnProvenance (dL->L _ n)) +repAnnProv (ValueAnnProvenance (L _ n)) = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level ; rep2 valueAnnotationName [ n' ] } -repAnnProv (TypeAnnProvenance (dL->L _ n)) +repAnnProv (TypeAnnProvenance (L _ n)) = do { MkC n' <- globalVar n ; rep2 typeAnnotationName [ n' ] } repAnnProv ModuleAnnProvenance @@ -739,17 +737,17 @@ repAnnProv ModuleAnnProvenance ------------------------------------------------------- repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) -repC (dL->L _ (ConDeclH98 { con_name = con - , con_forall = (dL->L _ False) - , con_mb_cxt = Nothing - , con_args = args })) +repC (L _ (ConDeclH98 { con_name = con + , con_forall = L _ False + , con_mb_cxt = Nothing + , con_args = args })) = repDataCon con args -repC (dL->L _ (ConDeclH98 { con_name = con - , con_forall = (dL->L _ is_existential) - , con_ex_tvs = con_tvs - , con_mb_cxt = mcxt - , con_args = args })) +repC (L _ (ConDeclH98 { con_name = con + , con_forall = L _ is_existential + , con_ex_tvs = con_tvs + , con_mb_cxt = mcxt + , con_args = args })) = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> do { c' <- repDataCon con args ; ctxt' <- repMbContext mcxt @@ -759,11 +757,11 @@ repC (dL->L _ (ConDeclH98 { con_name = con } } -repC (dL->L _ (ConDeclGADT { con_names = cons - , con_qvars = qtvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty })) +repC (L _ (ConDeclGADT { con_names = cons + , con_qvars = qtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty })) | isEmptyLHsQTvs qtvs -- No implicit or explicit variables , Nothing <- mcxt -- No context -- ==> no need for a forall @@ -783,7 +781,7 @@ repC _ = panic "repC" repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) repMbContext Nothing = repContext [] -repMbContext (Just (dL->L _ cxt)) = repContext cxt +repMbContext (Just (L _ cxt)) = repContext cxt repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] @@ -812,14 +810,14 @@ repBangTy ty = do ------------------------------------------------------- repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ]) -repDerivs (dL->L _ clauses) +repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses repDerivClause :: LHsDerivingClause GhcRn -> DsM (Core TH.DerivClauseQ) -repDerivClause (dL->L _ (HsDerivingClause +repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = (dL->L _ dct) })) + , deriv_clause_tys = L _ dct })) = do MkC dcs' <- repDerivStrategy dcs MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct rep2 derivClauseName [dcs',dct'] @@ -853,22 +851,22 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] rep_sigs = concatMapM rep_sig rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -rep_sig (dL->L loc (TypeSig _ nms ty)) +rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms -rep_sig (dL->L loc (PatSynSig _ nms ty)) +rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms -rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty)) +rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms | otherwise = mapM (rep_ty_sig sigDName loc ty) nms -rep_sig d@(dL->L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) -rep_sig (dL->L _ (FixSig {})) = return [] -- fixity sigs at top level -rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc -rep_sig (dL->L loc (SpecSig _ nm tys ispec)) +rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) +rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level +rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc +rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (dL->L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc -rep_sig (dL->L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty -rep_sig (dL->L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty -rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty)) +rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc +rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty +rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty +rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc rep_sig _ = panic "rep_sig" @@ -990,7 +988,7 @@ rep_complete_sig :: Located [Located Name] -> Maybe (Located Name) -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] -rep_complete_sig (dL->L _ cls) mty loc +rep_complete_sig (L _ cls) mty loc = do { mty' <- repMaybe nameTyConName lookupLOcc mty ; cls' <- repList nameTyConName lookupLOcc cls ; sig <- repPragComplete cls' mty' @@ -1066,18 +1064,18 @@ addTyClTyVarBinds tvs m -- repTyVarBndrWithKind :: LHsTyVarBndr GhcRn -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) -repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm +repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm = repPlainTV nm -repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm = repLTy ki >>= repKindedTV nm repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind" -- | Represent a type variable binder repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) -repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) ) +repTyVarBndr (L _ (UserTyVar _ (L _ nm)) ) = do { nm' <- lookupBinder nm ; repPlainTV nm' } -repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki)) +repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm ; ki' <- repLTy ki ; repKindedTV nm' ki' } @@ -1135,7 +1133,7 @@ repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf ty repTy ty@(HsQualTy {}) = repForall ForallInvis ty -repTy (HsTyVar _ _ (dL->L _ n)) +repTy (HsTyVar _ _ (L _ n)) | isLiftedTypeKindTyConName n = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | n `hasKey` funTyConKey = repArrowTyCon @@ -1216,11 +1214,10 @@ repMaybeLTy :: Maybe (LHsKind GhcRn) repMaybeLTy = repMaybe kindQTyConName repLTy repRole :: Located (Maybe Role) -> DsM (Core TH.Role) -repRole (dL->L _ (Just Nominal)) = rep2 nominalRName [] -repRole (dL->L _ (Just Representational)) = rep2 representationalRName [] -repRole (dL->L _ (Just Phantom)) = rep2 phantomRName [] -repRole (dL->L _ Nothing) = rep2 inferRName [] -repRole _ = panic "repRole: Impossible Match" -- due to #15884 +repRole (L _ (Just Nominal)) = rep2 nominalRName [] +repRole (L _ (Just Representational)) = rep2 representationalRName [] +repRole (L _ (Just Phantom)) = rep2 phantomRName [] +repRole (L _ Nothing) = rep2 inferRName [] ----------------------------------------------------------------------------- -- Splices @@ -1256,10 +1253,10 @@ repLEs es = repList expQTyConName repLE es -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) -repLE (dL->L loc e) = putSrcSpanDs loc (repE e) +repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) -repE (HsVar _ (dL->L _ x)) = +repE (HsVar _ (L _ x)) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x @@ -1279,8 +1276,8 @@ repE e@(HsRecFld _ f) = case f of -- HsOverlit can definitely occur repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit _ l) = do { a <- repLiteral l; repLit a } -repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m -repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) })) +repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m +repE (HsLamCase _ (MG { mg_alts = (L _ ms) })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreList matchQTyConName ms' ; repLamCase core_ms } @@ -1301,7 +1298,7 @@ repE (NegApp _ x _) = do repE (HsPar _ x) = repLE x repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) })) +repE (HsCase _ e (MG { mg_alts = (L _ ms) })) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreList matchQTyConName ms2 @@ -1315,13 +1312,13 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs +repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo _ ctxt (dL->L _ sts)) +repE e@(HsDo _ ctxt (L _ sts)) | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; e' <- repDoE (nonEmptyCoreList zs); @@ -1343,9 +1340,9 @@ repE e@(HsDo _ ctxt (dL->L _ sts)) repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) = let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ)) - tupArgToCoreExp a - | L _ (Present _ e) <- dL a = do { e' <- repLE e - ; coreJust expQTyConName e' } + tupArgToCoreExp (L _ a) + | Present _ e <- a = do { e' <- repLE e + ; coreJust expQTyConName e' } | otherwise = coreNothing expQTyConName in do { args <- mapM tupArgToCoreExp es @@ -1398,17 +1395,17 @@ repE (HsUnboundVar _ uv) = do sname <- repNameS occ repUnboundVar sname -repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) -repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) -repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) +repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e) +repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) +repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- --- Building representations of auxillary structures like Match, Clause, Stmt, +-- Building representations of auxiliary structures like Match, Clause, Stmt, repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) -repMatchTup (dL->L _ (Match { m_pats = [p] - , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = +repMatchTup (L _ (Match { m_pats = [p] + , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1420,8 +1417,8 @@ repMatchTup (dL->L _ (Match { m_pats = [p] repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) -repClauseTup (dL->L _ (Match { m_pats = ps - , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = +repClauseTup (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ guards (L _ wheres) })) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1430,11 +1427,11 @@ repClauseTup (dL->L _ (Match { m_pats = ps gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec +repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec repClauseTup _ = panic "repClauseTup" repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) -repGuards [dL->L _ (GRHS _ [] e)] +repGuards [L _ (GRHS _ [] e)] = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM repLGRHS other @@ -1444,10 +1441,10 @@ repGuards other repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) -repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2)) +repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2)) = do { guarded <- repLNormalGE e1 e2 ; return ([], guarded) } -repLGRHS (dL->L _ (GRHS _ ss rhs)) +repLGRHS (L _ (GRHS _ ss rhs)) = do { (gs, ss') <- repLSts ss ; rhs' <- addBinds gs $ repLE rhs ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' @@ -1460,16 +1457,16 @@ repFields (HsRecFields { rec_flds = flds }) where rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) -> DsM (Core (TH.Q TH.FieldExp)) - rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) - ; e <- repLE (hsRecFieldArg fld) - ; repFieldExp fn e } + rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) + ; e <- repLE (hsRecFieldArg fld) + ; repFieldExp fn e } repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) repUpdFields = repList fieldExpQTyConName rep_fld where rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp)) - rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of - Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name) + rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of + Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hsRecFieldArg fld) ; repFieldExp fn e } _ -> notHandled "Ambiguous record updates" (ppr fld) @@ -1481,7 +1478,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] -- First gensym new names for every variable in any of the patterns. -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) --- if variables didn't shaddow, the static gensym wouldn't be necessary +-- if variables didn't shadow, the static gensym wouldn't be necessary -- and we could reuse the original names (x and x). -- -- do { x'1 <- gensym "x" @@ -1513,7 +1510,7 @@ repSts (BindStmt _ p e _ _ : ss) = ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} -repSts (LetStmt _ (dL->L _ bs) : ss) = +repSts (LetStmt _ (L _ bs) : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) @@ -1590,18 +1587,16 @@ repBinds (HsValBinds _ decs) repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b) rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs))) +rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) = do { name <- case ename of - Left (dL->L _ n) -> rep_implicit_param_name n + Left (L _ n) -> rep_implicit_param_name n Right _ -> panic "rep_implicit_param_bind: post typechecking" ; rhs' <- repE rhs ; ipb <- repImplicitParamBind name rhs' ; return (loc, ipb) } -rep_implicit_param_bind (dL->L _ b@(XIPBind _)) +rep_implicit_param_bind (L _ b@(XIPBind _)) = notHandled "Implicit parameter bind extension" (ppr b) -rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match" - -- due to #15884 rep_implicit_param_name :: HsIPName -> DsM (Core String) rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) @@ -1624,13 +1619,12 @@ rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (dL->L loc (FunBind +rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts - = (dL->L _ [dL->L _ (Match - { m_pats = [] - , m_grhss = GRHSs _ guards - (dL->L _ wheres) } + = (L _ [L _ (Match + { m_pats = [] + , m_grhss = GRHSs _ guards (L _ wheres) } )]) } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -1640,26 +1634,26 @@ rep_bind (dL->L loc (FunBind ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (dL->L loc (FunBind { fun_id = fn - , fun_matches = MG { mg_alts = (dL->L _ ms) } })) +rep_bind (L loc (FunBind { fun_id = fn + , fun_matches = MG { mg_alts = L _ ms } })) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec +rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec -rep_bind (dL->L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs _ guards (dL->L _ wheres) })) +rep_bind (L loc (PatBind { pat_lhs = pat + , pat_rhs = GRHSs _ guards (L _ wheres) })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } -rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec +rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec -rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) +rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v ; e2 <- repLE e ; x <- repNormal e2 @@ -1668,11 +1662,11 @@ rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn - , psb_args = args - , psb_def = pat - , psb_dir = dir }))) +rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" +rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn + , psb_args = args + , psb_def = pat + , psb_dir = dir }))) = do { syn' <- lookupLBinder syn ; dir' <- repPatSynDir dir ; ss <- mkGenArgSyms args @@ -1707,11 +1701,8 @@ rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec -rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec))) - = noExtCon nec -rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec -rep_bind _ = panic "rep_bind: Impossible match!" - -- due to #15884 +rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec +rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec repPatSynD :: Core TH.Name -> Core TH.PatSynArgsQ @@ -1747,7 +1738,7 @@ repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) repPatSynDir Unidirectional = rep2 unidirPatSynName [] repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] -repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) })) +repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) })) = do { clauses' <- mapM repClauseTup clauses ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec @@ -1781,16 +1772,16 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) -repLambda (dL->L _ (Match { m_pats = ps - , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)] - (dL->L _ (EmptyLocalBinds _)) } )) +repLambda (L _ (Match { m_pats = ps + , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] + (L _ (EmptyLocalBinds _)) } )) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } -repLambda (dL->L _ m) = notHandled "Guarded lambdas" (pprMatch m) +repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m) ----------------------------------------------------------------------------- @@ -1837,12 +1828,12 @@ repP (ConPatIn dc details) } where rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ)) - rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) - ; MkC p <- repLP (hsRecFieldArg fld) - ; rep2 fieldPatName [v,p] } + rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) + ; MkC p <- repLP (hsRecFieldArg fld) + ; rep2 fieldPatName [v,p] } -repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l - ; repPlit a } +repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l + ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP (SigPat _ p t) = do { p' <- repLP p diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 5090bc8d81..2329a92d28 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -530,7 +530,7 @@ dsExtendMetaEnv menv thing_inside discardWarningsDs :: DsM a -> DsM a -- Ignore warnings inside the thing inside; --- used to ignore inaccessable cases etc. inside generated code +-- used to ignore inaccessible cases etc. inside generated code discardWarningsDs thing_inside = do { env <- getGblEnv ; old_msgs <- readTcRef (ds_msgs env) diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index b76c4f0592..c358c175c6 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -674,7 +674,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly -- and all the desugared binds mkSelectorBinds ticks pat val_expr - | (dL->L _ (VarPat _ (dL->L _ v))) <- pat' -- Special case (A) + | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) @@ -721,9 +721,9 @@ mkSelectorBinds ticks pat val_expr strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens -strip_bangs (dL->L _ (ParPat _ p)) = strip_bangs p -strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p -strip_bangs lp = lp +strip_bangs (L _ (ParPat _ p)) = strip_bangs p +strip_bangs (L _ (BangPat _ p)) = strip_bangs p +strip_bangs lp = lp is_flat_prod_lpat :: LPat (GhcPass p) -> Bool is_flat_prod_lpat = is_flat_prod_pat . unLoc @@ -731,7 +731,7 @@ is_flat_prod_lpat = is_flat_prod_pat . unLoc is_flat_prod_pat :: Pat (GhcPass p) -> Bool is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps -is_flat_prod_pat (ConPatOut { pat_con = (dL->L _ pcon) +is_flat_prod_pat (ConPatOut { pat_con = L _ pcon , pat_args = ps}) | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) @@ -759,7 +759,7 @@ is_triv_pat _ = False mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = cL (getLoc (head lpats)) $ +mkLHsPatTup lpats = L (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc @@ -952,25 +952,25 @@ decideBangHood dflags lpat | otherwise -- -XStrict = go lpat where - go lp@(dL->L l p) + go lp@(L l p) = case p of - ParPat x p -> cL l (ParPat x (go p)) + ParPat x p -> L l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp - _ -> cL l (BangPat noExtField lp) + _ -> L l (BangPat noExtField lp) -- | Unconditionally make a 'Pat' strict. addBang :: LPat GhcTc -- ^ Original pattern -> LPat GhcTc -- ^ Banged pattern addBang = go where - go lp@(dL->L l p) + go lp@(L l p) = case p of - ParPat x p -> cL l (ParPat x (go p)) - LazyPat _ lp' -> cL l (BangPat noExtField lp') + ParPat x p -> L l (ParPat x (go p)) + LazyPat _ lp' -> L l (BangPat noExtField lp') -- Should we bring the extension value over? BangPat _ _ -> lp - _ -> cL l (BangPat noExtField lp) + _ -> L l (BangPat noExtField lp) isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) @@ -980,24 +980,24 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v))) +isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey || v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon -isTrueLHsExpr (dL->L _ (HsConLikeOut _ con)) +isTrueLHsExpr (L _ (HsConLikeOut _ con)) | con `hasKey` getUnique trueDataCon = Just return -isTrueLHsExpr (dL->L _ (HsTick _ tickish e)) +isTrueLHsExpr (L _ (HsTick _ tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out. -isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e)) +isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (dL->L _ (HsPar _ e)) = isTrueLHsExpr e -isTrueLHsExpr _ = Nothing +isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr _ = Nothing diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs index 33bed3b3f5..ec5238ae4b 100644 --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -12,6 +12,7 @@ import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls import GHC.Hs.Extension +import GHC.Hs.Pat import GHC.Hs.Types import GHC.Hs.Utils import Name @@ -114,7 +115,8 @@ user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)] +getMainDeclBinder :: XRec pass Pat ~ Located (Pat pass) => + HsDecl pass -> [IdP pass] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -141,13 +143,13 @@ getInstLoc :: InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty) DataFamInstD _ (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l + { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l TyFamInstD _ (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some -- reason. - { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l + { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l ClsInstD _ (XClsInstDecl _) -> error "getInstLoc" DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc" @@ -164,7 +166,7 @@ subordinates :: Map SrcSpan Name subordinates instMap decl = case decl of InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = (dL->L l _) + FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn @@ -175,7 +177,7 @@ subordinates instMap decl = case decl of _ -> [] where classSubs dd = [ (name, doc, declTypeDocs d) - | (dL->L _ d, doc) <- classDecls dd + | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn @@ -189,8 +191,8 @@ subordinates instMap decl = case decl of | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) | RecCon flds <- map getConArgs cons - , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) - , (dL->L _ n) <- ns ] + , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) + , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty) | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $ concatMap (unLoc . deriv_clause_tys . unLoc) $ @@ -198,15 +200,15 @@ subordinates instMap decl = case decl of , Just instName <- [M.lookup l instMap] ] extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString) - extract_deriv_ty ty = - case dL ty of + extract_deriv_ty (L l ty) = + case ty of -- deriving (forall a. C a {- ^ Doc comment -}) - L l (HsForAllTy{ hst_fvf = ForallInvis - , hst_body = dL->L _ (HsDocTy _ _ doc) }) - -> Just (l, doc) + HsForAllTy{ hst_fvf = ForallInvis + , hst_body = L _ (HsDocTy _ _ doc) } + -> Just (l, doc) -- deriving (C a {- ^ Doc comment -}) - L l (HsDocTy _ _ doc) -> Just (l, doc) - _ -> Nothing + HsDocTy _ _ doc -> Just (l, doc) + _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 2e0aeb9877..b11a2e2f06 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -271,7 +271,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable - let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1 + let ViewPat _ viewExpr (L _ pat) = firstPat eqn1 -- do the rest of the compilation ; let pat_ty' = hsPatType pat ; var' <- newUniqueId var pat_ty' @@ -407,16 +407,16 @@ tidy1 :: Id -- The Id being scrutinised tidy1 v o (ParPat _ pat) = tidy1 v o (unLoc pat) tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p +tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v _ (VarPat _ (dL->L _ var)) +tidy1 v _ (VarPat _ (L _ var)) = return (wrapBind var v, WildPat (idType var)) -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v o (AsPat _ (dL->L _ var) pat) +tidy1 v o (AsPat _ (L _ var) pat) = do { (wrap, pat') <- tidy1 v o (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -472,7 +472,7 @@ tidy1 _ o (LitPat _ lit) ; return (idDsWrapper, tidyLitPat lit) } -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq) +tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) = do { unless (isGenerated o) $ let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } | otherwise = lit @@ -480,7 +480,7 @@ tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq) ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } -- NPlusKPat: we may want to warn about the literals -tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _) +tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) = do { unless (isGenerated o) $ do warnAboutOverflowedOverLit lit1 warnAboutOverflowedOverLit lit2 @@ -495,15 +495,15 @@ tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang -tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p -tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p +tidy_bang_pat v o _ (ParPat _ (L l p)) = tidy_bang_pat v o l p +tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time tidy_bang_pat v o l (AsPat x v' p) - = tidy1 v o (AsPat x v' (cL l (BangPat noExtField p))) + = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) tidy_bang_pat v o l (CoPat x w p t) - = tidy1 v o (CoPat x w (BangPat noExtField (cL l p)) t) + = tidy1 v o (CoPat x w (BangPat noExtField (L l p)) t) -- Discard bang around strict pattern tidy_bang_pat v o _ p@(LitPat {}) = tidy1 v o p @@ -512,7 +512,7 @@ tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p -- Data/newtype constructors -tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc)) +tidy_bang_pat v o l p@(ConPatOut { pat_con = L _ (RealDataCon dc) , pat_args = args , pat_arg_tys = arg_tys }) -- Newtypes: push bang inwards (#9844) @@ -538,7 +538,7 @@ tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc)) -- -- NB: SigPatIn, ConPatIn should not happen -tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (cL l p)) +tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) ------------------- push_bang_into_newtype_arg :: SrcSpan @@ -549,16 +549,16 @@ push_bang_into_newtype_arg :: SrcSpan -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = ASSERT( null args) - PrefixCon [cL l (BangPat noExtField arg)] + PrefixCon [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf) - | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf + | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsRecField { hsRecFieldArg = arg } <- fld = ASSERT( null flds) - RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg - = cL l (BangPat noExtField arg) })] }) + RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg + = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [cL l (BangPat noExtField (noLoc (WildPat ty)))] + = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -724,7 +724,7 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 -} -matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) +matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches , mg_ext = MatchGroupTc arg_tys rhs_ty , mg_origin = origin }) = do { dflags <- getDynFlags @@ -747,7 +747,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) ; return (new_vars, result_expr) } where -- Called once per equation in the match, or alternative in the case - mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss })) + mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss })) = do { dflags <- getDynFlags ; let upats = map (unLoc . decideBangHood dflags) pats dicts = collectEvVarsPats upats @@ -763,8 +763,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches) ; return (EqnInfo { eqn_pats = upats , eqn_orig = FromSource , eqn_rhs = match_result }) } - mk_eqn_info _ (dL->L _ (XMatch nec)) = noExtCon nec - mk_eqn_info _ _ = panic "mk_eqn_info: Impossible Match" -- due to #15884 + mk_eqn_info _ (L _ (XMatch nec)) = noExtCon nec handleWarnings = if isGenerated origin then discardWarningsDs @@ -1004,8 +1003,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens - exp (HsPar _ (dL->L _ e)) e' = exp e e' - exp e (HsPar _ (dL->L _ e')) = exp e e' + exp (HsPar _ (L _ e)) e' = exp e e' + exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e' @@ -1058,8 +1057,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 wrap res_wrap1 res_wrap2 --------- - tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2 - tup_arg (dL->L _ (Missing t1)) (dL->L _ (Missing t2)) = eqType t1 t2 + tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 + tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2 tup_arg _ _ = False --------- @@ -1094,13 +1093,13 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys patGroup :: DynFlags -> Pat GhcTc -> PatGroup -patGroup _ (ConPatOut { pat_con = (dL->L _ con) +patGroup _ (ConPatOut { pat_con = L _ con , pat_arg_tys = tys }) | RealDataCon dcon <- con = PgCon dcon | PatSynCon psyn <- con = PgSyn psyn tys patGroup _ (WildPat {}) = PgAny patGroup _ (BangPat {}) = PgBang -patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) = +patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = case (oval, isJust mb_neg) of (HsIntegral i, False) -> PgN (fromInteger (il_value i)) (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) @@ -1108,7 +1107,7 @@ patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) = (HsFractional r, True ) -> PgN (-fl_value r) (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) PgOverS s -patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) = +patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) _ -> pprPanic "patGroup NPlusKPat" (ppr oval) diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index be65433c3b..43d71acfdf 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -170,7 +170,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where - ConPatOut { pat_con = (dL->L _ con1) + ConPatOut { pat_con = L _ con1 , pat_arg_tys = arg_tys, pat_wrap = wrapper1, pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } = firstPat eqn1 @@ -192,7 +192,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor = arg_vars where fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars - lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env + lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env (idName (unLoc (hsRecFieldId rpat))) select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" matchOneConLike _ _ [] = panic "matchOneCon []" @@ -209,7 +209,7 @@ compatible_pats _ _ = True -- Prefix or infix co same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) -> Bool same_fields flds1 flds2 - = all2 (\(dL->L _ f1) (dL->L _ f2) + = all2 (\(L _ f1) (L _ f2) -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2)) (rec_flds flds1) (rec_flds flds2) diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 126346b935..4f65362b2b 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -288,11 +288,11 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name) -- ^ See if the expression is an 'Integral' literal. -- Remember to look through automatically-added tick-boxes! (#8384) -getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit -getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit +getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit +getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit getLHsIntegralLit _ = Nothing -- | If 'Integral', extract the value and type name of the overloaded literal. @@ -469,7 +469,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l) matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1 + = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit ; neg_lit <- case mb_neg of Nothing -> return lit_expr @@ -500,7 +500,7 @@ We generate: matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus + = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus = firstPat eqn1 ; lit1_expr <- dsOverLit lit1 ; lit2_expr <- dsOverLit lit2 @@ -513,7 +513,7 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns) adjustMatchResult (foldr1 (.) wraps) $ match_result) } where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats }) + shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) = (wrapBind n n1, eqn { eqn_pats = pats }) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 50b4422e64..e77dcd3768 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -374,8 +374,8 @@ patScopes -> [LPat (GhcPass p)] -> [PScoped (LPat (GhcPass p))] patScopes rsp useScope patScope xs = - map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $ - listScopes patScope (map dL xs) + map (\(RS sc a) -> PS rsp useScope sc a) $ + listScopes patScope xs -- | 'listScopes' specialised to 'TVScoped' things tvScopes @@ -402,7 +402,7 @@ bar (x :: forall a. a -> a) = ... -- a is not in scope here bax (x :: a) = ... -- a is in scope here Because of HsWC and HsIB pass on their scope to their children we must wrap the LHsType in pattern signatures in a -Shielded explictly, so that the HsWC/HsIB scope is not passed +Shielded explicitly, so that the HsWC/HsIB scope is not passed on the the LHsType -} @@ -579,10 +579,10 @@ instance HasType (LHsBind GhcTc) where _ -> makeNode bind spn instance HasType (Located (Pat GhcRn)) where - getTypeNode (dL -> L spn pat) = makeNode pat spn + getTypeNode (L spn pat) = makeNode pat spn instance HasType (Located (Pat GhcTc)) where - getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat) + getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat) instance HasType (LHsExpr GhcRn) where getTypeNode (L spn e) = makeNode e spn @@ -766,7 +766,7 @@ instance ( a ~ GhcPass p , HasType (LPat a) , Data (HsSplice a) ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where - toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) = + toHie (PS rsp scope pscope lpat@(L ospan opat)) = concatM $ getTypeNode lpat : case opat of WildPat _ -> [] @@ -778,7 +778,7 @@ instance ( a ~ GhcPass p ] AsPat _ lname pat -> [ toHie $ C (PatternBind scope - (combineScopes (mkLScope (dL pat)) pscope) + (combineScopes (mkLScope pat) pscope) rsp) lname , toHie $ PS rsp scope pscope pat @@ -822,7 +822,7 @@ instance ( a ~ GhcPass p ] SigPat _ pat sig -> [ toHie $ PS rsp scope pscope pat - , let cscope = mkLScope (dL pat) in + , let cscope = mkLScope pat in toHie $ TS (ResolvedScopes [cscope, scope, pscope]) (protectSig @a cscope sig) -- See Note [Scoping Rules for SigPat] @@ -978,10 +978,7 @@ instance ( a ~ GhcPass p ArithSeq _ _ info -> [ toHie info ] - HsSCC _ _ _ expr -> - [ toHie expr - ] - HsCoreAnn _ _ _ expr -> + HsPragE _ _ expr -> [ toHie expr ] HsProc _ pat cmdtop -> @@ -997,9 +994,6 @@ instance ( a ~ GhcPass p HsBinTick _ _ _ expr -> [ toHie expr ] - HsTickPragma _ _ _ _ expr -> - [ toHie expr - ] HsWrap _ _ a -> [ toHie $ L mspan a ] diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs index 864c09ce2e..2bcfa82c96 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -87,7 +87,7 @@ allocateGlobalBinder name_supply mod occ loc -- of the Name, so we set this field in the Name we return. -- -- Then (bogus) multiple bindings of the same Name - -- get different SrcLocs can can be reported as such. + -- get different SrcLocs can be reported as such. -- -- Possible other reason: it might be in the cache because we -- encountered an occurrence before the binding site for an diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 1482c689cb..82350195ee 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -67,7 +67,7 @@ import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import Var( VarBndr(..), binderVar ) import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) -import Util( dropList, filterByList, notNull, unzipWith ) +import Util( dropList, filterByList, notNull, unzipWith, debugIsOn ) import DataCon (SrcStrictness(..), SrcUnpackedness(..)) import Lexeme (isLexSym) import TysWiredIn ( constraintKindTyConName ) @@ -590,7 +590,7 @@ pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs , ifaxbLHS = pat_tys , ifaxbRHS = rhs , ifaxbIncomps = incomps }) - = WARN( not (null _cvs), pp_tc $$ ppr _cvs ) + = ASSERT2( null _cvs, pp_tc $$ ppr _cvs ) hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) $+$ nest 4 maybe_incomps diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 44e8e7088a..8aba2418f3 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -881,7 +881,7 @@ ppr_ty ctxt_prec (IfaceCoercionTy co) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ RuntimeRep variables are considered by many (most?) users to be little more than syntactic noise. When the notion was introduced there was a -signficant and understandable push-back from those with pedagogy in +significant and understandable push-back from those with pedagogy in mind, which argued that RuntimeRep variables would throw a wrench into nearly any teach approach since they appear in even the lowly ($) function's type, diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 2485f07df2..38f7524b8e 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -549,7 +549,7 @@ But there is a HORRIBLE HACK here. * And that means we end up loading M.hi-boot, because those data types are not yet in the type environment. -But in this wierd case, /all/ we need is the types. We don't need +But in this weird case, /all/ we need is the types. We don't need instances, rules etc. And if we put the instances in the EPS we get "duplicate instance" warnings when we compile the "real" instance in M itself. Hence the strange business of just updateing diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 6e349d813f..f477aa64ed 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -843,8 +843,10 @@ ppDouble d [x,y] -> [x,y] _ -> error "dToStr: too many hex digits for float" - str = map toUpper $ concat $ fixEndian $ map hex bs - in text "0x" <> text str + in sdocWithDynFlags (\dflags -> + let fixEndian = if wORDS_BIGENDIAN dflags then id else reverse + str = map toUpper $ concat $ fixEndian $ map hex bs + in text "0x" <> text str) -- Note [LLVM Float Types] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -874,14 +876,6 @@ widenFp = float2Double ppFloat :: Float -> SDoc ppFloat = ppDouble . widenFp --- | Reverse or leave byte data alone to fix endianness on this target. -fixEndian :: [a] -> [a] -#if defined(WORDS_BIGENDIAN) -fixEndian = id -#else -fixEndian = reverse -#endif - -------------------------------------------------------------------------------- -- * Misc functions diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index f86207e081..c8d88a8c2a 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -833,6 +833,7 @@ cmmPrimOpFunctions mop = do MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs index f8637e506a..e4320b7cc9 100644 --- a/compiler/main/Annotations.hs +++ b/compiler/main/Annotations.hs @@ -21,12 +21,14 @@ module Annotations ( import GhcPrelude import Binary -import Module ( Module ) +import Module ( Module + , ModuleEnv, emptyModuleEnv, extendModuleEnvWith + , plusModuleEnv_C, lookupWithDefaultModuleEnv + , mapModuleEnv ) +import NameEnv import Name import Outputable import GHC.Serialized -import UniqFM -import Unique import Control.Monad import Data.Maybe @@ -60,11 +62,6 @@ getAnnTargetName_maybe :: AnnTarget name -> Maybe name getAnnTargetName_maybe (NamedTarget nm) = Just nm getAnnTargetName_maybe _ = Nothing -instance Uniquable name => Uniquable (AnnTarget name) where - getUnique (NamedTarget nm) = getUnique nm - getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0 - -- deriveUnique prevents OccName uniques clashing with NamedTarget - instance Outputable name => Outputable (AnnTarget name) where ppr (NamedTarget nm) = text "Named target" <+> ppr nm ppr (ModuleTarget mod) = text "Module target" <+> ppr mod @@ -86,12 +83,13 @@ instance Outputable Annotation where ppr ann = ppr (ann_target ann) -- | A collection of annotations --- Can't use a type synonym or we hit bug #2412 due to source import -newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload]) +data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload]) + , ann_name_env :: !(NameEnv [AnnPayload]) + } -- | An empty annotation environment. emptyAnnEnv :: AnnEnv -emptyAnnEnv = MkAnnEnv emptyUFM +emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv -- | Construct a new annotation environment that contains the list of -- annotations provided. @@ -100,33 +98,51 @@ mkAnnEnv = extendAnnEnvList emptyAnnEnv -- | Add the given annotation to the environment. extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv -extendAnnEnvList (MkAnnEnv env) anns - = MkAnnEnv $ addListToUFM_C (++) env $ - map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns +extendAnnEnvList env = + foldl' extendAnnEnv env + +extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv +extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) = + case tgt of + NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload]) + ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env -- | Union two annotation environments. plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv -plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 +plusAnnEnv a b = + MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b) + , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b) + } -- | Find the annotations attached to the given target as 'Typeable' -- values of your choice. If no deserializer is specified, -- only transient annotations will be returned. findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] -findAnns deserialize (MkAnnEnv ann_env) - = (mapMaybe (fromSerialized deserialize)) - . (lookupWithDefaultUFM ann_env []) +findAnns deserialize env + = mapMaybe (fromSerialized deserialize) . findAnnPayloads env -- | Find the annotations attached to the given target as 'Typeable' -- values of your choice. If no deserializer is specified, -- only transient annotations will be returned. findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] -findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep - = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target +findAnnsByTypeRep env target tyrep + = [ ws | Serialized tyrep' ws <- findAnnPayloads env target , tyrep' == tyrep ] +-- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'. +findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload] +findAnnPayloads env target = + case target of + ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod + NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name + -- | Deserialize all annotations of a given type. This happens lazily, that is -- no deserialization will take place until the [a] is actually demanded and -- the [a] can also be empty (the UniqFM is not filtered). -deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] -deserializeAnns deserialize (MkAnnEnv ann_env) - = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env +deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a]) +deserializeAnns deserialize env + = ( mapModuleEnv deserAnns (ann_mod_env env) + , mapNameEnv deserAnns (ann_name_env env) + ) + where deserAnns = mapMaybe (fromSerialized deserialize) + diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index ff0186a56b..62a4826edb 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -160,7 +160,7 @@ compileOne' m_tc_result mHscMessage debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) -- Run the pipeline up to codeGen (so everything up to, but not including, STG) - (status, hmi_details, plugin_dflags) <- hscIncrementalCompile + (status, plugin_dflags) <- hscIncrementalCompile always_do_basic_recompilation_check m_tc_result mHscMessage hsc_env summary source_modified mb_old_iface (mod_index, nmods) @@ -178,27 +178,27 @@ compileOne' m_tc_result mHscMessage let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags } case (status, hsc_lang) of - (HscUpToDate iface, _) -> + (HscUpToDate iface hmi_details, _) -> -- TODO recomp014 triggers this assert. What's going on?! -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) ) return $! HomeModInfo iface hmi_details mb_old_linkable - (HscNotGeneratingCode iface, HscNothing) -> + (HscNotGeneratingCode iface hmi_details, HscNothing) -> let mb_linkable = if isHsBootOrSig src_flavour then Nothing -- TODO: Questionable. else Just (LM (ms_hs_date summary) this_mod []) in return $! HomeModInfo iface hmi_details mb_linkable - (HscNotGeneratingCode _, _) -> panic "compileOne HscNotGeneratingCode" + (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode" (_, HscNothing) -> panic "compileOne HscNothing" - (HscUpdateBoot iface, HscInterpreted) -> do + (HscUpdateBoot iface hmi_details, HscInterpreted) -> do return $! HomeModInfo iface hmi_details Nothing - (HscUpdateBoot iface, _) -> do + (HscUpdateBoot iface hmi_details, _) -> do touchObjectFile dflags object_filename return $! HomeModInfo iface hmi_details Nothing - (HscUpdateSig iface, HscInterpreted) -> do + (HscUpdateSig iface hmi_details, HscInterpreted) -> do let !linkable = LM (ms_hs_date summary) this_mod [] return $! HomeModInfo iface hmi_details (Just linkable) - (HscUpdateSig iface, _) -> do + (HscUpdateSig iface hmi_details, _) -> do output_fn <- getOutputFilename next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) @@ -210,7 +210,7 @@ compileOne' m_tc_result mHscMessage (output_fn, Nothing, Just (HscOut src_flavour - mod_name (HscUpdateSig iface))) + mod_name (HscUpdateSig iface hmi_details))) (Just basename) Persistent (Just location) @@ -220,6 +220,7 @@ compileOne' m_tc_result mHscMessage return $! HomeModInfo iface hmi_details (Just linkable) (HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location, + hscs_mod_details = hmi_details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash, hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do @@ -252,7 +253,7 @@ compileOne' m_tc_result mHscMessage (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) -- We're in --make mode: finish the compilation pipeline. - (_, _, Just iface) <- runPipeline StopLn hsc_env' + (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env' (output_fn, Nothing, Just (HscOut src_flavour mod_name status)) @@ -263,7 +264,7 @@ compileOne' m_tc_result mHscMessage -- The object filename comes from the ModLocation o_time <- getModificationUTCTime object_filename let !linkable = LM o_time this_mod [DotO object_filename] - return $! HomeModInfo iface hmi_details (Just linkable) + return $! HomeModInfo iface details (Just linkable) where dflags0 = ms_hspp_opts summary this_mod = ms_mod summary @@ -602,7 +603,7 @@ runPipeline -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects - -> IO (DynFlags, FilePath, Maybe ModIface) + -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails)) -- ^ (final flags, output filename, interface) runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) mb_basename output maybe_loc foreign_os @@ -697,7 +698,7 @@ runPipeline' -> FilePath -- ^ Input filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects, if we have one - -> IO (DynFlags, FilePath, Maybe ModIface) + -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails)) -- ^ (final flags, output filename, interface) runPipeline' start_phase hsc_env env input_fn maybe_loc foreign_os @@ -1134,7 +1135,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 -- run the compiler! let msg hsc_env _ what _ = oneShotMsg hsc_env what - (result, _mod_details, plugin_dflags) <- + (result, plugin_dflags) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' mod_summary source_unchanged Nothing (1,1) @@ -1153,21 +1154,21 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do next_phase = hscPostBackendPhase src_flavour hsc_lang case result of - HscNotGeneratingCode _ -> + HscNotGeneratingCode _ _ -> return (RealPhase StopLn, panic "No output filename from Hsc when no-code") - HscUpToDate _ -> + HscUpToDate _ _ -> do liftIO $ touchObjectFile dflags o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't get Nothing) -- but we touch it anyway, to keep 'make' happy (we think). return (RealPhase StopLn, o_file) - HscUpdateBoot _ -> + HscUpdateBoot _ _ -> do -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make liftIO $ touchObjectFile dflags o_file return (RealPhase StopLn, o_file) - HscUpdateSig _ -> + HscUpdateSig _ _ -> do -- We need to create a REAL but empty .o file -- because we are going to attempt to put it in a library PipeState{hsc_env=hsc_env'} <- getPipeState @@ -1177,6 +1178,7 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do return (RealPhase StopLn, o_file) HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location, + hscs_mod_details = mod_details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash, hscs_iface_dflags = iface_dflags } @@ -1188,7 +1190,11 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do hscGenHardCode hsc_env' cgguts mod_location output_fn final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface) - setIface final_iface + -- TODO(osa): ModIface and ModDetails need to be in sync, + -- but we only generate ModIface with the backend info. See + -- !2100 for more discussion on this. This will be fixed + -- with !1304 or !2100. + setIface final_iface mod_details -- See Note [Writing interface files] let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 70f50f2a8b..d3cd6577ab 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -557,6 +557,7 @@ data GeneralFlag | Opt_UnboxSmallStrictFields | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification + | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation | Opt_PedanticBottoms -- Be picky about how we treat bottom @@ -4136,7 +4137,8 @@ wWarningFlagsDeps = [ flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, flagSpec "star-binder" Opt_WarnStarBinder, flagSpec "star-is-type" Opt_WarnStarIsType, - flagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang, + depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang + "bang patterns can no longer be written with a space", flagSpec "partial-fields" Opt_WarnPartialFields, flagSpec "prepositive-qualified-module" Opt_WarnPrepositiveQualifiedModule, @@ -4208,6 +4210,7 @@ fFlagsDeps = [ flagSpec "eager-blackholing" Opt_EagerBlackHoling, flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, + flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, flagSpec "error-spans" Opt_ErrorSpans, flagSpec "excess-precision" Opt_ExcessPrecision, flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs index 648f20aad9..9e19de12dd 100644 --- a/compiler/main/Elf.hs +++ b/compiler/main/Elf.hs @@ -408,15 +408,6 @@ readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do -- | Generate the GAS code to create a Note section -- -- Header fields for notes are 32-bit long (see Note [ELF specification]). --- --- It seems there is no easy way to force GNU AS to generate a 32-bit word in --- every case. Hence we use .int directive to create them: however "The byte --- order and bit size of the number depends on what kind of target the assembly --- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int) --- --- If we add new target platforms, we need to check that the generated words --- are 32-bit long, otherwise we need to use platform specific directives to --- force 32-bit .int in asWord32. makeElfNote :: String -> String -> Word32 -> String -> SDoc makeElfNote sectionName noteName typ contents = hcat [ text "\t.section ", @@ -424,6 +415,7 @@ makeElfNote sectionName noteName typ contents = hcat [ text ",\"\",", sectionType "note", text "\n", + text "\t.balign 4\n", -- note name length (+ 1 for ending \0) asWord32 (length noteName + 1), @@ -438,20 +430,20 @@ makeElfNote sectionName noteName typ contents = hcat [ text "\t.asciz \"", text noteName, text "\"\n", - text "\t.align 4\n", + text "\t.balign 4\n", -- note contents (.ascii to avoid ending \0) + padding text "\t.ascii \"", text (escape contents), text "\"\n", - text "\t.align 4\n"] + text "\t.balign 4\n"] where escape :: String -> String escape = concatMap (charToC.fromIntegral.ord) asWord32 :: Show a => a -> SDoc asWord32 x = hcat [ - text "\t.int ", + text "\t.4byte ", text (show x), text "\n"] diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index f0fa1441f9..c66496bc61 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -879,7 +879,7 @@ the whole thing with 'withTiming'. Instead we wrap the processing of each individual stream element, all along the codegen pipeline, using the appropriate label for the pass to which this processing belongs. That generates a lot more data but allows us to get fine-grained timings about all the passes and we can -easily compute totals withh tools like ghc-events-analyze (see below). +easily compute totals with tools like ghc-events-analyze (see below). Producing an eventlog for GHC diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 53c7680302..80131c6329 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -257,9 +257,6 @@ module GHC ( getLoc, unLoc, getRealSrcSpan, unRealSrcSpan, - -- ** HasSrcSpan - HasSrcSpan(..), SrcSpanLess, dL, cL, - -- *** Combining and comparing Located values eqLocated, cmpLocated, combineLocs, addCLoc, leftmost_smallest, leftmost_largest, rightmost, @@ -1392,7 +1389,7 @@ getRichTokenStream mod = do addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] -> [(Located Token, String)] addSourceToTokens _ _ [] = [] -addSourceToTokens loc buf (t@(dL->L span _) : ts) +addSourceToTokens loc buf (t@(L span _) : ts) = case span of UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts @@ -1418,7 +1415,7 @@ showRichTokenStream ts = go startLoc ts "" getFile (RealSrcSpan s : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id - go loc ((dL->L span _, str):ts) + go loc ((L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts RealSrcSpan s diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 6599da07f4..93bdb85f19 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -730,7 +730,7 @@ findPartiallyCompletedCycles modsDone theGraph -- -- | Unloading unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' +unload hsc_env stable_linkables -- Unload everything *except* 'stable_linkables' = case ghcLink (hsc_dflags hsc_env) of LinkInMemory -> Linker.unload hsc_env stable_linkables _other -> return () diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index bd984618a4..96361591e9 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -85,7 +85,7 @@ getImports dflags buf filename source_filename = do imps = hsmodImports hsmod main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) - mod = mb_mod `orElse` cL main_loc mAIN_NAME + mod = mb_mod `orElse` L main_loc mAIN_NAME (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. @@ -96,8 +96,7 @@ getImports dflags buf filename source_filename = do implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps - convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i) - , ideclName i) + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) in return (map convImport src_idecls, map convImport (implicit_imports ++ ordinary_imps), @@ -120,23 +119,23 @@ mkPrelImports this_mod loc implicit_prelude import_decls | otherwise = [preludeImportDecl] where explicit_prelude_import - = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod - , ideclPkgQual = Nothing })) + = notNull [ () | L _ (ImportDecl { ideclName = mod + , ideclPkgQual = Nothing }) <- import_decls , unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = cL loc $ ImportDecl { ideclExt = noExtField, - ideclSourceSrc = NoSourceText, - ideclName = cL loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, -- Not a safe import - ideclQualified = NotQualified, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } + = L loc $ ImportDecl { ideclExt = noExtField, + ideclSourceSrc = NoSourceText, + ideclName = L loc pRELUDE_NAME, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, -- Not a safe import + ideclQualified = NotQualified, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } -------------------------------------------------------------- -- Get options @@ -192,7 +191,7 @@ lazyGetToks dflags filename handle = do _other -> do rest <- lazyLexBuf handle state' eof size return (t : rest) _ | not eof -> getMore handle state size - | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof] + | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end getMore :: Handle -> PState -> Int -> IO [Located Token] @@ -214,9 +213,9 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc) loc = mkRealSrcLoc (mkFastString filename) 1 1 lexAll state = case unP (lexer False return) state of - POk _ t@(dL->L _ ITeof) -> [t] + POk _ t@(L _ ITeof) -> [t] POk state' t -> t : lexAll state' - _ -> [cL (RealSrcSpan (last_loc state)) ITeof] + _ -> [L (RealSrcSpan (last_loc state)) ITeof] -- | Parse OPTIONS and LANGUAGE pragmas of the source file. @@ -245,16 +244,16 @@ getOptions' dflags toks = case toArgs str of Left _err -> optionsParseError str dflags $ -- #15053 combineSrcSpans (getLoc open) (getLoc close) - Right args -> map (cL (getLoc open)) args ++ parseToks xs + Right args -> map (L (getLoc open)) args ++ parseToks xs parseToks (open:close:xs) | ITinclude_prag str <- unLoc open , ITclose_prag <- unLoc close - = map (cL (getLoc open)) ["-#include",removeSpaces str] ++ + = map (L (getLoc open)) ["-#include",removeSpaces str] ++ parseToks xs parseToks (open:close:xs) | ITdocOptions str <- unLoc open , ITclose_prag <- unLoc close - = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str] + = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] ++ parseToks xs parseToks (open:xs) | ITlanguage_prag <- unLoc open @@ -263,12 +262,12 @@ getOptions' dflags toks | isComment (unLoc comment) = parseToks xs parseToks _ = [] - parseLanguage ((dL->L loc (ITconid fs)):rest) - = checkExtension dflags (cL loc fs) : + parseLanguage ((L loc (ITconid fs)):rest) + = checkExtension dflags (L loc fs) : case rest of - (dL->L _loc ITcomma):more -> parseLanguage more - (dL->L _loc ITclose_prag):more -> parseToks more - (dL->L loc _):_ -> languagePragParseError dflags loc + (L _loc ITcomma):more -> parseLanguage more + (L _loc ITclose_prag):more -> parseToks more + (L loc _):_ -> languagePragParseError dflags loc [] -> panic "getOptions'.parseLanguage(1) went past eof token" parseLanguage (tok:_) = languagePragParseError dflags (getLoc tok) @@ -296,7 +295,7 @@ checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () checkProcessArgsResult dflags flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags - where mkMsg (dL->L loc flag) + where mkMsg (L loc flag) = mkPlainErrMsg dflags loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) @@ -304,11 +303,11 @@ checkProcessArgsResult dflags flags ----------------------------------------------------------------------------- checkExtension :: DynFlags -> Located FastString -> Located String -checkExtension dflags (dL->L l ext) +checkExtension dflags (L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception. = if ext' `elem` supported - then cL l ("-X"++ext') + then L l ("-X"++ext') else unsupportedExtnError dflags l ext' where ext' = unpackFS ext @@ -336,11 +335,11 @@ optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Mess optionsErrorMsgs dflags unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) where unhandled_flags_lines :: [Located String] - unhandled_flags_lines = [ cL l f + unhandled_flags_lines = [ L l f | f <- unhandled_flags - , (dL->L l f') <- flags_lines + , L l f' <- flags_lines , f == f' ] - mkMsg (dL->L flagSpan flag) = + mkMsg (L flagSpan flag) = ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 3d2ac983a4..9daecdb550 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -727,7 +727,7 @@ hscIncrementalCompile :: Bool -> SourceModified -> Maybe ModIface -> (Int,Int) - -> IO (HscStatus, ModDetails, DynFlags) + -> IO (HscStatus, DynFlags) hscIncrementalCompile always_do_basic_recompilation_check m_tc_result mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index = do @@ -768,14 +768,14 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result -- in make mode, since this HMI will go into the HPT. details <- genModDetails hsc_env' iface return details - return (HscUpToDate iface, details, dflags) + return (HscUpToDate iface details, dflags) -- We finished type checking. (mb_old_hash is the hash of -- the interface that existed on disk; it's possible we had -- to retypecheck but the resulting interface is exactly -- the same.) Right (FrontendTypecheck tc_result, mb_old_hash) -> do - (status, mb_old_hash) <- finish mod_summary tc_result mb_old_hash - return (status, mb_old_hash, dflags) + status <- finish mod_summary tc_result mb_old_hash + return (status, dflags) -- Runs the post-typechecking frontend (desugar and simplify). We want to -- generate most of the interface as late as possible. This gets us up-to-date @@ -792,7 +792,7 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result finish :: ModSummary -> TcGblEnv -> Maybe Fingerprint - -> Hsc (HscStatus, ModDetails) + -> Hsc HscStatus finish summary tc_result mb_old_hash = do hsc_env <- getHscEnv let dflags = hsc_dflags hsc_env @@ -800,20 +800,18 @@ finish summary tc_result mb_old_hash = do hsc_src = ms_hsc_src summary should_desugar = ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile - mk_simple_iface :: Hsc (HscStatus, ModDetails) + mk_simple_iface :: Hsc HscStatus mk_simple_iface = do (iface, mb_old_iface_hash, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary) - let hsc_status = - case (target, hsc_src) of - (HscNothing, _) -> HscNotGeneratingCode iface - (_, HsBootFile) -> HscUpdateBoot iface - (_, HsigFile) -> HscUpdateSig iface - _ -> panic "finish" - return (hsc_status, details) + return $ case (target, hsc_src) of + (HscNothing, _) -> HscNotGeneratingCode iface details + (_, HsBootFile) -> HscUpdateBoot iface details + (_, HsigFile) -> HscUpdateSig iface details + _ -> panic "finish" if should_desugar then do @@ -839,12 +837,12 @@ finish summary tc_result mb_old_hash = do -- See Note [Avoiding space leaks in toIface*] for details. force (mkPartialIface hsc_env details desugared_guts) - return ( HscRecomp { hscs_guts = cg_guts, - hscs_mod_location = ms_location summary, - hscs_partial_iface = partial_iface, - hscs_old_iface_hash = mb_old_hash, - hscs_iface_dflags = dflags }, - details ) + return HscRecomp { hscs_guts = cg_guts, + hscs_mod_location = ms_location summary, + hscs_mod_details = details, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_hash, + hscs_iface_dflags = dflags } else mk_simple_iface diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 27f192227f..a5072a7690 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -22,7 +22,7 @@ import Data.Char -- | Source Statistics ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc -ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) +ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) = (if short then hcat else vcat) (map pp_val [("ExportAll ", export_all), -- 1 if no export list @@ -84,7 +84,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls val_decls = [d | ValD _ d <- decls] - real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es } + real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } n_exports = length real_exports export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True ; _ -> False}) @@ -104,7 +104,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) = sum5 (map inst_info inst_decls) - count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0) + count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) count_bind (PatBind {}) = (0,1,0) count_bind (FunBind {}) = (0,1,0) count_bind (PatSynBind {}) = (0,0,1) @@ -119,12 +119,10 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) sig_info (ClassOpSig {}) = (0,0,0,0,1) sig_info _ = (0,0,0,0,0) - import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual - , ideclAs = as, ideclHiding = spec })) + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) - import_info (dL->L _ (XImportDecl nec)) = noExtCon nec - import_info _ = panic " import_info: Impossible Match" - -- due to #15884 + import_info (L _ (XImportDecl nec)) = noExtCon nec safe_info False = 0 safe_info True = 1 @@ -138,7 +136,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _)) data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs - , dd_derivs = (dL->L _ derivs)}}) + , dd_derivs = L _ derivs}}) = ( length cs , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) 0 derivs ) diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 67510d851c..0ce14369fd 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -232,19 +232,20 @@ import Control.DeepSeq -- | Status of a compilation to hard-code data HscStatus -- | Nothing to do. - = HscNotGeneratingCode ModIface + = HscNotGeneratingCode ModIface ModDetails -- | Nothing to do because code already exists. - | HscUpToDate ModIface + | HscUpToDate ModIface ModDetails -- | Update boot file result. - | HscUpdateBoot ModIface + | HscUpdateBoot ModIface ModDetails -- | Generate signature file (backpack) - | HscUpdateSig ModIface + | HscUpdateSig ModIface ModDetails -- | Recompile this module. | HscRecomp { hscs_guts :: CgGuts -- ^ Information for the code generator. , hscs_mod_location :: !ModLocation -- ^ Module info + , hscs_mod_details :: !ModDetails , hscs_partial_iface :: !PartialModIface -- ^ Partial interface , hscs_old_iface_hash :: !(Maybe Fingerprint) @@ -385,7 +386,7 @@ handleFlagWarnings dflags warns = do -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) - | Warn _ (dL->L loc warn) <- warns' ] + | Warn _ (L loc warn) <- warns' ] printOrThrowWarnings dflags bag diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index baed7f5ec1..b3ee7f5e6c 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -2135,7 +2135,7 @@ isDllName dflags this_mod name -- On Windows the hack for #8696 makes it unlinkable. -- As the entire setup of the code from Cmm down to the RTS expects -- the use of trampolines for the imported functions only when - -- doing intra-package linking, e.g. refering to a symbol defined in the same + -- doing intra-package linking, e.g. referring to a symbol defined in the same -- package should not use a trampoline. -- I much rather have dynamic TH not supported than the entire Dynamic linking -- not due to a hack. diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs index bdda19ceac..a3608ac4cd 100644 --- a/compiler/main/PipelineMonad.hs +++ b/compiler/main/PipelineMonad.hs @@ -72,7 +72,7 @@ data PipeState = PipeState { -- ^ additional object files resulting from compiling foreign -- code. They come from two sources: foreign stubs, and -- add{C,Cxx,Objc,Objcxx}File from template haskell - iface :: Maybe ModIface + iface :: Maybe (ModIface, ModDetails) -- ^ Interface generated by HscOut phase. Only available after the -- phase runs. } @@ -80,7 +80,7 @@ data PipeState = PipeState { pipeStateDynFlags :: PipeState -> DynFlags pipeStateDynFlags = hsc_dflags . hsc_env -pipeStateModIface :: PipeState -> Maybe ModIface +pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails) pipeStateModIface = iface data PipelineOutput @@ -118,5 +118,5 @@ setForeignOs :: [FilePath] -> CompPipeline () setForeignOs os = P $ \_env state -> return (state{ foreign_os = os }, ()) -setIface :: ModIface -> CompPipeline () -setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ()) +setIface :: ModIface -> ModDetails -> CompPipeline () +setIface iface details = P $ \_env state -> return (state{ iface = Just (iface, details) }, ()) diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs index 96a5b291da..ee6824327a 100644 --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -242,7 +242,7 @@ runLink dflags args = traceToolCommand dflags "linker" $ do -- -- `-optl` args come at the end, so that later `-l` options -- given there manually can fill in symbols needed by - -- Haskell libaries coming in via `args`. + -- Haskell libraries coming in via `args`. linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags let (p,args0) = pgm_l dflags optl_args = map Option (getOpts dflags opt_l) diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index ae491ac02d..f087d96bca 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -1280,7 +1280,7 @@ So we have to *predict* the result here, which is revolting. In particular CorePrep expands Integer and Natural literals. So in the prediction code here we resort to applying the same expansion (cvt_literal). -There are also numberous other ways in which we can introduce inconsistencies +There are also numerous other ways in which we can introduce inconsistencies between CorePrep and TidyPgm. See Note [CAFfyness inconsistencies due to eta expansion in TidyPgm] for one such example. diff --git a/compiler/main/ToolSettings.hs b/compiler/main/ToolSettings.hs index 952e5869fc..82d125b5f6 100644 --- a/compiler/main/ToolSettings.hs +++ b/compiler/main/ToolSettings.hs @@ -9,7 +9,7 @@ import Fingerprint -- | Settings for other executables GHC calls. -- --- Probably should futher split down by phase, or split between +-- Probably should further split down by phase, or split between -- platform-specific and platform-agnostic. data ToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind :: Bool diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs index 56e3177dd8..ba15e0063f 100644 --- a/compiler/nativeGen/BlockLayout.hs +++ b/compiler/nativeGen/BlockLayout.hs @@ -76,10 +76,10 @@ import Control.Monad (foldM) We have a CFG with edge weights based on which we try to place blocks next to each other. - Edge weights not only represent likelyhood of control transfer between blocks + Edge weights not only represent likelihood of control transfer between blocks but also how much a block would benefit from being placed sequentially after it's predecessor. - For example blocks which are preceeded by an info table are more likely to end + For example blocks which are preceded by an info table are more likely to end up in a different cache line than their predecessor and we can't eliminate the jump so there is less benefit to placing them sequentially. @@ -359,7 +359,7 @@ takeL n (BlockChain blks) = -- While we could take into account the space between the two blocks which -- share an edge this blows up compile times quite a bit. It requires -- us to find all edges between two chains, check the distance for all edges, --- rank them based on the distance and and only then we can select two chains +-- rank them based on the distance and only then we can select two chains -- to combine. Which would add a lot of complexity for little gain. -- -- So instead we just rank by the strength of the edge and use the first pair we @@ -891,4 +891,3 @@ lookupDeleteUFM :: Uniquable key => UniqFM elt -> key lookupDeleteUFM m k = do -- Maybe monad v <- lookupUFM m k return (v, delFromUFM m k) - diff --git a/compiler/nativeGen/Format.hs b/compiler/nativeGen/Format.hs index 31472893e7..745d1e7b65 100644 --- a/compiler/nativeGen/Format.hs +++ b/compiler/nativeGen/Format.hs @@ -3,7 +3,7 @@ -- -- TODO: Signed vs unsigned? -- --- TODO: This module is currenly shared by all architectures because +-- TODO: This module is currently shared by all architectures because -- NCGMonad need to know about it to make a VReg. It would be better -- to have architecture specific formats, and do the overloading -- properly. eg SPARC doesn't care about FF80. diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 7ea68e1105..a38f3fa18f 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -420,7 +420,7 @@ picRelative dflags arch OSDarwin lbl -- On AIX we use an indirect local TOC anchored by 'gotLabel'. -- This way we use up only one global TOC entry per compilation-unit --- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode) +-- (this is quite similar to GCC's @-mminimal-toc@ compilation mode) picRelative dflags _ OSAIX lbl = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags) @@ -623,7 +623,7 @@ pprImportedSymbol _ (Platform { platformMini = PlatformMini { platformMini_os = -- XCOFF / AIX -- --- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To +-- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To -- workaround the limitation of a global TOC we use an indirect TOC -- with the label `ghc_toc_table`. -- diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 5f852973ae..05883d0e5a 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -602,7 +602,7 @@ getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps _ -> case x of CmmLit (CmmInt imm _) | Just _ <- makeImmediate rep True imm - -- subfi ('substract from' with immediate) doesn't exist + -- subfi ('subtract from' with immediate) doesn't exist -> trivialCode rep True SUBFC y x _ -> trivialCodeNoImm' (intFormat rep) SUBF y x @@ -1690,7 +1690,7 @@ genCCall' dflags gcp target dest_regs args `appOL` codeAfter) GCPAIX -> return ( dynCode -- AIX/XCOFF follows the PowerOPEN ABI - -- which is quite similiar to LinuxPPC64/ELFv1 + -- which is quite similar to LinuxPPC64/ELFv1 `appOL` codeBefore `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20)) `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0)) @@ -2021,6 +2021,7 @@ genCCall' dflags gcp target dest_regs args MO_AtomicRead _ -> unsupported MO_AtomicWrite _ -> unsupported + MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index eccc83eb48..22a88c02c0 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -297,7 +297,7 @@ patchInstr patchInstr reg instr = do nUnique <- newUnique - -- The register we're rewriting is suppoed to be virtual. + -- The register we're rewriting is supposed to be virtual. -- If it's not then something has gone horribly wrong. let nReg = case reg of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 52f590948a..4be25a71ba 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -297,7 +297,7 @@ nodeDegree classOfVirtualReg graph reg -- | Show a spill cost record, including the degree from the graph --- and final calulated spill cost. +-- and final calculated spill cost. pprSpillCostRecord :: (VirtualReg -> RegClass) -> (Reg -> SDoc) diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs index fbbb786817..f4170cca94 100644 --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -12,7 +12,7 @@ import Unique -- | The class of a register. -- Used in the register allocator. --- We treat all registers in a class as being interchangable. +-- We treat all registers in a class as being interchangeable. -- data RegClass = RcInteger diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index e24180e535..46b29d0a03 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -681,6 +681,7 @@ outOfLineMachOp_table mop MO_AtomicRead w -> fsLit $ atomicReadLabel w MO_AtomicWrite w -> fsLit $ atomicWriteLabel w + MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index a29c24dcd4..237311956e 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -51,7 +51,7 @@ expandBlockInstrs (ii:is) -- | In the SPARC instruction set the FP register pairs that are used --- to hold 64 bit floats are refered to by just the first reg +-- to hold 64 bit floats are referred to by just the first reg -- of the pair. Remap our internal reg pairs to the appropriate reg. -- -- For example: diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 1807bdcea1..59a1e4115b 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -2613,6 +2613,26 @@ genCCall' _ is32Bit target dest_regs args bid = do MOV format (OpReg rax) (OpReg reg_l)] return code _ -> panic "genCCall: Wrong number of arguments/results for mul2" + (PrimTarget (MO_S_Mul2 width), [res_c, res_h, res_l]) -> + case args of + [arg_x, arg_y] -> + do (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + reg_tmp <- getNewRegNat II8 + let format = intFormat width + reg_h = getRegisterReg platform (CmmLocal res_h) + reg_l = getRegisterReg platform (CmmLocal res_l) + reg_c = getRegisterReg platform (CmmLocal res_c) + code = y_code `appOL` + x_code rax `appOL` + toOL [ IMUL2 format y_reg + , MOV format (OpReg rdx) (OpReg reg_h) + , MOV format (OpReg rax) (OpReg reg_l) + , SETCC CARRY (OpReg reg_tmp) + , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c) + ] + return code + _ -> panic "genCCall: Wrong number of arguments/results for imul2" _ -> if is32Bit then genCCall32' dflags target dest_regs args @@ -3204,6 +3224,7 @@ outOfLineCmmOp bid mop res args MO_UF_Conv _ -> unsupported + MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 7e47860143..80a2c8b28e 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -816,7 +816,7 @@ x86_mkJumpInstr id -- | | -- +-------------------+ -- --- In essense each allocation larger than a page size needs to be chunked and +-- In essence each allocation larger than a page size needs to be chunked and -- a probe emitted after each page allocation. You have to hit the guard -- page so the kernel can map in the next page, otherwise you'll segfault. -- diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index bfb39c8f7b..ca88716f34 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -258,9 +258,9 @@ data AnnKeywordId | AnnOpenEQ -- ^ '[|' | AnnOpenEQU -- ^ '[|', unicode variant | AnnOpenP -- ^ '(' - | AnnOpenPE -- ^ '$(' - | AnnOpenPTE -- ^ '$$(' | AnnOpenS -- ^ '[' + | AnnDollar -- ^ prefix '$' -- TemplateHaskell + | AnnDollarDollar -- ^ prefix '$$' -- TemplateHaskell | AnnPackageName | AnnPattern | AnnProc diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 2ada289db4..fc6779a359 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -44,6 +44,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -376,10 +377,6 @@ $tab { warnTab } "[t|" / { ifExtension ThQuotesBit } { token ITopenTypQuote } "|]" / { ifExtension ThQuotesBit } { token (ITcloseQuote NormalSyntax) } "||]" / { ifExtension ThQuotesBit } { token ITcloseTExpQuote } - \$ @varid / { ifExtension ThBit } { skip_one_varid ITidEscape } - "$$" @varid / { ifExtension ThBit } { skip_two_varid ITidTyEscape } - "$(" / { ifExtension ThBit } { token ITparenEscape } - "$$(" / { ifExtension ThBit } { token ITparenTyEscape } "[" @varid "|" / { ifExtension QqBit } { lex_quasiquote_tok } @@ -398,14 +395,6 @@ $tab { warnTab } { token (ITcloseQuote UnicodeSyntax) } } - -- See Note [Lexing type applications] -<0> { - [^ $idchar \) ] ^ - "@" - / { ifExtension TypeApplicationsBit `alexAndPred` notFollowedBySymbol } - { token ITtypeApp } -} - <0> { "(|" / { ifExtension ArrowsBit `alexAndPred` @@ -471,12 +460,20 @@ $tab { warnTab } @conid "#"+ / { ifExtension MagicHashBit } { idtoken conid } } +-- Operators classified into prefix, suffix, tight infix, and loose infix. +-- See Note [Whitespace-sensitive operator parsing] +<0> { + @varsym / { precededByClosingToken `alexAndPred` followedByOpeningToken } { varsym_tight_infix } + @varsym / { followedByOpeningToken } { varsym_prefix } + @varsym / { precededByClosingToken } { varsym_suffix } + @varsym { varsym_loose_infix } +} + -- ToDo: - move `var` and (sym) into lexical syntax? -- - remove backquote from $special? <0> { @qvarsym { idtoken qvarsym } @qconsym { idtoken qconsym } - @varsym { varsym } @consym { consym } } @@ -550,32 +547,114 @@ $tab { warnTab } \" { lex_string_tok } } --- Note [Lexing type applications] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The desired syntax for type applications is to prefix the type application --- with '@', like this: +-- Note [Whitespace-sensitive operator parsing] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In accord with GHC Proposal #229 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst +-- we classify operator occurrences into four categories: +-- +-- a ! b -- a loose infix occurrence +-- a!b -- a tight infix occurrence +-- a !b -- a prefix occurrence +-- a! b -- a suffix occurrence +-- +-- The rules are a bit more elaborate than simply checking for whitespace, in +-- order to accommodate the following use cases: +-- +-- f (!a) = ... -- prefix occurrence +-- g (a !) -- loose infix occurrence +-- g (! a) -- loose infix occurrence +-- +-- The precise rules are as follows: +-- +-- * Identifiers, literals, and opening brackets (, (#, [, [|, [||, [p|, [e|, +-- [t|, {, are considered "opening tokens". The function followedByOpeningToken +-- tests whether the next token is an opening token. +-- +-- * Identifiers, literals, and closing brackets ), #), ], |], }, +-- are considered "closing tokens". The function precededByClosingToken tests +-- whether the previous token is a closing token. -- --- foo @Int @Bool baz bum +-- * Whitespace, comments, separators, and other tokens, are considered +-- neither opening nor closing. -- --- This, of course, conflicts with as-patterns. The conflict arises because --- expressions and patterns use the same parser, and also because we want --- to allow type patterns within expression patterns. +-- * Any unqualified operator occurrence is classified as prefix, suffix, or +-- tight/loose infix, based on preceding and following tokens: -- --- Disambiguation is accomplished by requiring *something* to appear between --- type application and the preceding token. This something must end with --- a character that cannot be the end of the variable bound in an as-pattern. --- Currently (June 2015), this means that the something cannot end with a --- $idchar or a close-paren. (The close-paren is necessary if the as-bound --- identifier is symbolic.) +-- precededByClosingToken | followedByOpeningToken | Occurrence +-- ------------------------+------------------------+------------ +-- False | True | prefix +-- True | False | suffix +-- True | True | tight infix +-- False | False | loose infix +-- ------------------------+------------------------+------------ -- --- Note that looking for whitespace before the '@' is insufficient, because --- of this pathological case: +-- A loose infix occurrence is always considered an operator. Other types of +-- occurrences may be assigned a special per-operator meaning override: -- --- foo {- hi -}@Int +-- Operator | Occurrence | Token returned +-- ----------+---------------+------------------------------------------ +-- ! | prefix | ITbang +-- | | strictness annotation or bang pattern, +-- | | e.g. f !x = rhs, data T = MkT !a +-- | not prefix | ITvarsym "!" +-- | | ordinary operator or type operator, +-- | | e.g. xs ! 3, (! x), Int ! Bool +-- ----------+---------------+------------------------------------------ +-- ~ | prefix | ITtilde +-- | | laziness annotation or lazy pattern, +-- | | e.g. f ~x = rhs, data T = MkT ~a +-- | not prefix | ITvarsym "~" +-- | | ordinary operator or type operator, +-- | | e.g. xs ~ 3, (~ x), Int ~ Bool +-- ----------+---------------+------------------------------------------ +-- $ $$ | prefix | ITdollar, ITdollardollar +-- | | untyped or typed Template Haskell splice, +-- | | e.g. $(f x), $$(f x), $$"str" +-- | not prefix | ITvarsym "$", ITvarsym "$$" +-- | | ordinary operator or type operator, +-- | | e.g. f $ g x, a $$ b +-- ----------+---------------+------------------------------------------ +-- @ | prefix | ITtypeApp +-- | | type application, e.g. fmap @Maybe +-- | tight infix | ITat +-- | | as-pattern, e.g. f p@(a,b) = rhs +-- | suffix | parse error +-- | | e.g. f p@ x = rhs +-- | loose infix | ITvarsym "@" +-- | | ordinary operator or type operator, +-- | | e.g. f @ g, (f @) +-- ----------+---------------+------------------------------------------ -- --- This design is predicated on the fact that as-patterns are generally --- whitespace-free, and also that this whole thing is opt-in, with the --- TypeApplications extension. +-- Also, some of these overrides are guarded behind language extensions. +-- According to the specification, we must determine the occurrence based on +-- surrounding *tokens* (see the proposal for the exact rules). However, in +-- the implementation we cheat a little and do the classification based on +-- characters, for reasons of both simplicity and efficiency (see +-- 'followedByOpeningToken' and 'precededByClosingToken') +-- +-- When an operator is subject to a meaning override, it is mapped to special +-- token: ITbang, ITtilde, ITat, ITdollar, ITdollardollar. Otherwise, it is +-- returned as ITvarsym. +-- +-- For example, this is how we process the (!): +-- +-- precededByClosingToken | followedByOpeningToken | Token +-- ------------------------+------------------------+------------- +-- False | True | ITbang +-- True | False | ITvarsym "!" +-- True | True | ITvarsym "!" +-- False | False | ITvarsym "!" +-- ------------------------+------------------------+------------- +-- +-- And this is how we process the (@): +-- +-- precededByClosingToken | followedByOpeningToken | Token +-- ------------------------+------------------------+------------- +-- False | True | ITtypeApp +-- True | False | parse error +-- True | True | ITat +-- False | False | ITvarsym "@" +-- ------------------------+------------------------+------------- -- ----------------------------------------------------------------------------- -- Alex "Haskell code fragment bottom" @@ -680,11 +759,12 @@ data Token | ITvbar | ITlarrow IsUnicodeSyntax | ITrarrow IsUnicodeSyntax - | ITat - | ITtilde | ITdarrow IsUnicodeSyntax | ITminus - | ITbang + | ITbang -- Prefix (!) only, e.g. f !x = rhs + | ITtilde -- Prefix (~) only, e.g. f ~x = rhs + | ITat -- Tight infix (@) only, e.g. f x@pat = rhs + | ITtypeApp -- Prefix (@) only, e.g. f @t | ITstar IsUnicodeSyntax | ITdot @@ -740,10 +820,8 @@ data Token | ITcloseQuote IsUnicodeSyntax -- |] | ITopenTExpQuote HasE -- [|| or [e|| | ITcloseTExpQuote -- ||] - | ITidEscape FastString -- $x - | ITparenEscape -- $( - | ITidTyEscape FastString -- $$x - | ITparenTyEscape -- $$( + | ITdollar -- prefix $ + | ITdollardollar -- prefix $$ | ITtyQuote -- '' | ITquasiQuote (FastString,FastString,RealSrcSpan) -- ITquasiQuote(quoter, quote, loc) @@ -764,11 +842,6 @@ data Token | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@ | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@ - -- | Type application '@' (lexed differently than as-pattern '@', - -- due to checking for preceding whitespace) - | ITtypeApp - - | ITunknown String -- ^ Used when the lexer can't make sense of it | ITeof -- ^ end of file token @@ -889,11 +962,8 @@ reservedSymsFM = listToUFM $ ,("|", ITvbar, NormalSyntax, 0 ) ,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 ) ,("->", ITrarrow NormalSyntax, NormalSyntax, 0 ) - ,("@", ITat, NormalSyntax, 0 ) - ,("~", ITtilde, NormalSyntax, 0 ) ,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 ) ,("-", ITminus, NormalSyntax, 0 ) - ,("!", ITbang, NormalSyntax, 0 ) ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) @@ -988,6 +1058,32 @@ pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState act span buf len +-- See Note [Whitespace-sensitive operator parsing] +followedByOpeningToken :: AlexAccPred ExtsBitmap +followedByOpeningToken _ _ _ (AI _ buf) + | atEnd buf = False + | otherwise = + case nextChar buf of + ('{', buf') -> nextCharIsNot buf' (== '-') + ('(', _) -> True + ('[', _) -> True + ('\"', _) -> True + ('\'', _) -> True + ('_', _) -> True + (c, _) -> isAlphaNum c + +-- See Note [Whitespace-sensitive operator parsing] +precededByClosingToken :: AlexAccPred ExtsBitmap +precededByClosingToken _ (AI _ buf) _ _ = + case prevChar buf '\n' of + '}' -> decodePrevNChars 1 buf /= "-" + ')' -> True + ']' -> True + '\"' -> True + '\'' -> True + '_' -> True + c -> isAlphaNum c + {-# INLINE nextCharIs #-} nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf) @@ -1348,11 +1444,40 @@ qvarsym, qconsym :: StringBuffer -> Int -> Token qvarsym buf len = ITqvarsym $! splitQualName buf len False qconsym buf len = ITqconsym $! splitQualName buf len False -varsym, consym :: Action -varsym = sym ITvarsym -consym = sym ITconsym - -sym :: (FastString -> Token) -> Action +-- See Note [Whitespace-sensitive operator parsing] +varsym_prefix :: Action +varsym_prefix = sym $ \exts s -> + if | TypeApplicationsBit `xtest` exts, s == fsLit "@" + -> return ITtypeApp + | ThBit `xtest` exts, s == fsLit "$" + -> return ITdollar + | ThBit `xtest` exts, s == fsLit "$$" + -> return ITdollardollar + | s == fsLit "!" -> return ITbang + | s == fsLit "~" -> return ITtilde + | otherwise -> return (ITvarsym s) + +-- See Note [Whitespace-sensitive operator parsing] +varsym_suffix :: Action +varsym_suffix = sym $ \_ s -> + if | s == fsLit "@" + -> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace." + | otherwise -> return (ITvarsym s) + +-- See Note [Whitespace-sensitive operator parsing] +varsym_tight_infix :: Action +varsym_tight_infix = sym $ \_ s -> + if | s == fsLit "@" -> return ITat + | otherwise -> return (ITvarsym s) + +-- See Note [Whitespace-sensitive operator parsing] +varsym_loose_infix :: Action +varsym_loose_infix = sym (\_ s -> return $ ITvarsym s) + +consym :: Action +consym = sym (\_exts s -> return $ ITconsym s) + +sym :: (ExtsBitmap -> FastString -> P Token) -> Action sym con span buf len = case lookupUFM reservedSymsFM fs of Just (keyword, NormalSyntax, 0) -> @@ -1361,19 +1486,20 @@ sym con span buf len = exts <- getExts if exts .&. i /= 0 then return $ L span keyword - else return $ L span (con fs) + else L span <$!> con exts fs Just (keyword, UnicodeSyntax, 0) -> do exts <- getExts if xtest UnicodeSyntaxBit exts then return $ L span keyword - else return $ L span (con fs) + else L span <$!> con exts fs Just (keyword, UnicodeSyntax, i) -> do exts <- getExts if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts then return $ L span keyword - else return $ L span (con fs) - Nothing -> - return $ L span $! con fs + else L span <$!> con exts fs + Nothing -> do + exts <- getExts + L span <$!> con exts fs where !fs = lexemeToFastString buf len @@ -2889,8 +3015,6 @@ isALRopen ITobrack = True isALRopen ITocurly = True -- GHC Extensions: isALRopen IToubxparen = True -isALRopen ITparenEscape = True -isALRopen ITparenTyEscape = True isALRopen _ = False isALRclose :: Token -> Bool @@ -2945,12 +3069,9 @@ lexToken = do let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes lt <- t span buf bytes - case unRealSrcSpan lt of - ITlineComment _ -> return lt - ITblockComment _ -> return lt - lt' -> do - setLastTk lt' - return lt + let lt' = unRealSrcSpan lt + unless (isComment lt') (setLastTk lt') + return lt reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a reportLexError loc1 loc2 buf str diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 5fea8646a4..0076a01992 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -93,7 +93,7 @@ import Util ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) import GhcPrelude } -%expect 236 -- shift/reduce conflicts +%expect 232 -- shift/reduce conflicts {- Last updated: 04 June 2018 @@ -541,18 +541,18 @@ are the most common patterns, rewritten as regular expressions for clarity: '|' { L _ ITvbar } '<-' { L _ (ITlarrow _) } '->' { L _ (ITrarrow _) } - '@' { L _ ITat } - '~' { L _ ITtilde } + TIGHT_INFIX_AT { L _ ITat } '=>' { L _ (ITdarrow _) } '-' { L _ ITminus } - '!' { L _ ITbang } + PREFIX_TILDE { L _ ITtilde } + PREFIX_BANG { L _ ITbang } '*' { L _ (ITstar _) } '-<' { L _ (ITlarrowtail _) } -- for arrow notation '>-' { L _ (ITrarrowtail _) } -- for arrow notation '-<<' { L _ (ITLarrowtail _) } -- for arrow notation '>>-' { L _ (ITRarrowtail _) } -- for arrow notation '.' { L _ ITdot } - TYPEAPP { L _ ITtypeApp } + PREFIX_AT { L _ ITtypeApp } '{' { L _ ITocurly } -- special symbols '}' { L _ ITccurly } @@ -610,10 +610,8 @@ are the most common patterns, rewritten as regular expressions for clarity: '|]' { L _ (ITcloseQuote _) } '[||' { L _ (ITopenTExpQuote _) } '||]' { L _ ITcloseTExpQuote } -TH_ID_SPLICE { L _ (ITidEscape _) } -- $x -'$(' { L _ ITparenEscape } -- $( exp ) -TH_ID_TY_SPLICE { L _ (ITidTyEscape _) } -- $$x -'$$(' { L _ ITparenTyEscape } -- $$( exp ) +PREFIX_DOLLAR { L _ ITdollar } +PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar } TH_TY_QUOTE { L _ ITtyQuote } -- ''T TH_QUASIQUOTE { L _ (ITquasiQuote _) } TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } @@ -647,8 +645,6 @@ identifier :: { Located RdrName } | qconop { $1 } | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) [mop $1,mu AnnRarrow $2,mcp $3] } - | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) - [mop $1,mj AnnTilde $2,mcp $3] } ----------------------------------------------------------------------------- -- Backpack stuff @@ -764,7 +760,7 @@ unitdecl :: { LHsUnitDecl PackageName } signature :: { Located (HsModule GhcPs) } : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) + ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1) ) ([mj AnnSignature $2, mj AnnWhere $6] ++ fst $7) } @@ -772,13 +768,13 @@ signature :: { Located (HsModule GhcPs) } module :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 (fst $ snd $7) + ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1) ) ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } | body2 {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule Nothing Nothing + ams (L loc (HsModule Nothing Nothing (fst $ snd $1) (snd $ snd $1) Nothing Nothing)) (fst $1) } @@ -829,15 +825,15 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } header :: { Located (HsModule GhcPs) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 + ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (cL loc (HsModule (Just $3) $5 $7 [] $4 $1 + ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } | header_body2 {% fileSrcSpan >>= \ loc -> - return (cL loc (HsModule Nothing Nothing $1 [] Nothing + return (L loc (HsModule Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl GhcPs] } @@ -909,7 +905,7 @@ qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of - l@(dL->L _ ImpExpQcWildcard) -> + l@(L _ ImpExpQcWildcard) -> return ([mj AnnComma $2, mj AnnDotdot l] ,(snd (unLoc $3) : snd $1)) l -> (ams (head (snd $1)) [mj AnnComma $2] >> @@ -971,7 +967,7 @@ importdecl :: { LImportDecl GhcPs } : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec {% do { ; checkImportDecl $4 $7 - ; ams (cL (comb4 $1 $6 (snd $8) $9) $ + ; ams (L (comb4 $1 $6 (snd $8) $9) $ ImportDecl { ideclExt = noExtField , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 @@ -1018,7 +1014,7 @@ maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> - return (cL (gl $1) (Just (b, checkedIe))) } + return (L (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } impspec :: { Located (Bool, Located [LIE GhcPs]) } @@ -1167,7 +1163,7 @@ inst_decl :: { LInstDecl GhcPs } , cid_tyfam_insts = ats , cid_overlap_mode = $2 , cid_datafam_insts = adts } - ; ams (cL (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) + ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) (mj AnnInstance $1 : (fst $ unLoc $4)) } } -- type instance declarations @@ -1254,24 +1250,24 @@ where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) } ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) } : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] ,Just (unLoc $2)) } - | vocurly ty_fam_inst_eqns close { let (dL->L loc _) = $2 in - cL loc ([],Just (unLoc $2)) } + | vocurly ty_fam_inst_eqns close { let (L loc _) = $2 in + L loc ([],Just (unLoc $2)) } | '{' '..' '}' { sLL $1 $> ([moc $1,mj AnnDotdot $2 ,mcc $3],Nothing) } - | vocurly '..' close { let (dL->L loc _) = $2 in - cL loc ([mj AnnDotdot $2],Nothing) } + | vocurly '..' close { let (L loc _) = $2 in + L loc ([mj AnnDotdot $2],Nothing) } ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% let (dL->L loc (anns, eqn)) = $3 in - asl (unLoc $1) $2 (cL loc eqn) + {% let (L loc (anns, eqn)) = $3 in + asl (unLoc $1) $2 (L loc eqn) >> ams $3 anns - >> return (sLL $1 $> (cL loc eqn : unLoc $1)) } + >> return (sLL $1 $> (L loc eqn : unLoc $1)) } | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn {% let (dL->L loc (anns, eqn)) = $1 in + | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in ams $1 anns - >> return (sLL $1 $> [cL loc eqn]) } + >> return (sLL $1 $> [L loc eqn]) } | {- empty -} { noLoc [] } ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } @@ -1508,7 +1504,7 @@ where_decls :: { Located ([AddAnn] , Located (OrdList (LHsDecl GhcPs))) } : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } - | 'where' vocurly decls close { cL (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) + | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) ,sL1 $3 (snd $ unLoc $3)) } pattern_synonym_sig :: { LSig GhcPs } @@ -1592,7 +1588,7 @@ decllist_inst :: { Located ([AddAnn] , OrdList (LHsDecl GhcPs)) } -- Reversed : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } - | vocurly decls_inst close { cL (gl $2) (unLoc $2) } + | vocurly decls_inst close { L (gl $2) (unLoc $2) } -- Instance body -- @@ -1628,7 +1624,7 @@ decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) } : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) ,sL1 $2 $ snd $ unLoc $2) } - | vocurly decls close { cL (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } + | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- @@ -1642,7 +1638,7 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } - | vocurly dbinds close { cL (getLoc $2) ([] + | vocurly dbinds close { L (getLoc $2) ([] ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } @@ -1670,7 +1666,7 @@ rule :: { LRuleDecl GhcPs } {%runECP_P $4 >>= \ $4 -> runECP_P $6 >>= \ $6 -> ams (sLL $1 $> $ HsRule { rd_ext = noExtField - , rd_name = cL (gl $1) (getSTRINGs $1, getSTRING $1) + , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 , rd_lhs = $4, rd_rhs = $6 }) @@ -1681,13 +1677,30 @@ rule_activation :: { ([AddAnn],Maybe Activation) } : {- empty -} { ([],Nothing) } | rule_explicit_activation { (fst $1,Just (snd $1)) } +-- This production is used to parse the tilde syntax in pragmas such as +-- * {-# INLINE[~2] ... #-} +-- * {-# SPECIALISE [~ 001] ... #-} +-- * {-# RULES ... [~0] ... g #-} +-- Note that it can be written either +-- without a space [~1] (the PREFIX_TILDE case), or +-- with a space [~ 1] (the VARSYM case). +-- See Note [Whitespace-sensitive operator parsing] in Lexer.x +rule_activation_marker :: { [AddAnn] } + : PREFIX_TILDE { [mj AnnTilde $1] } + | VARSYM {% if (getVARSYM $1 == fsLit "~") + then return [mj AnnTilde $1] + else do { addError (getLoc $1) $ text "Invalid rule activation marker" + ; return [] } } + rule_explicit_activation :: { ([AddAnn] ,Activation) } -- In brackets : '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3] ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } - | '[' '~' INTEGER ']' { ([mos $1,mj AnnTilde $2,mj AnnVal $3,mcs $4] + | '[' rule_activation_marker INTEGER ']' + { ($2++[mos $1,mj AnnVal $3,mcs $4] ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) } - | '[' '~' ']' { ([mos $1,mj AnnTilde $2,mcs $3] + | '[' rule_activation_marker ']' + { ($2++[mos $1,mcs $3] ,NeverActive) } rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs]) } @@ -1765,14 +1778,14 @@ deprecation :: { OrdList (LWarnDecl GhcPs) } (fst $ unLoc $2) } strings :: { Located ([AddAnn],[Located StringLiteral]) } - : STRING { sL1 $1 ([],[cL (gl $1) (getStringLiteral $1)]) } + : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } stringlist :: { Located (OrdList (Located StringLiteral)) } : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> (unLoc $1 `snocOL` - (cL (gl $3) (getStringLiteral $3)))) } - | STRING { sLL $1 $> (unitOL (cL (gl $1) (getStringLiteral $1))) } + (L (gl $3) (getStringLiteral $3)))) } + | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } | {- empty -} { noLoc nilOL } ----------------------------------------------------------------------------- @@ -1826,7 +1839,7 @@ safety :: { Located Safety } fspec :: { Located ([AddAnn] ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] - ,(cL (getLoc $1) + ,(L (getLoc $1) (getStringLiteral $1), $2, mkLHsSigType $4)) } | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } @@ -1872,7 +1885,7 @@ unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) } forall_vis_flag :: { (AddAnn, ForallVisFlag) } : '.' { (mj AnnDot $1, ForallInvis) } - | '->' { (mj AnnRarrow $1, ForallVis) } + | '->' { (mu AnnRarrow $1, ForallVis) } -- A ktype/ktypedoc is a ctype/ctypedoc, possibly with a kind annotation ktype :: { LHsType GhcPs } @@ -1992,13 +2005,13 @@ typedoc :: { LHsType GhcPs } [mu AnnRarrow $2] } | btype docprev '->' ctypedoc {% ams $1 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExtField (cL (comb2 $1 $2) + HsFunTy noExtField (L (comb2 $1 $2) (HsDocTy noExtField $1 $2)) $4) [mu AnnRarrow $3] } | docnext btype '->' ctypedoc {% ams $2 [mu AnnRarrow $3] -- See note [GADT decl discards annotations] >> ams (sLL $1 $> $ - HsFunTy noExtField (cL (comb2 $1 $2) + HsFunTy noExtField (L (comb2 $1 $2) (HsDocTy noExtField $2 $1)) $4) [mu AnnRarrow $3] } @@ -2026,10 +2039,11 @@ tyapps :: { [Located TyEl] } -- NB: This list is reversed tyapp :: { Located TyEl } : atype { sL1 $1 $ TyElOpd (unLoc $1) } - | TYPEAPP atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) } - | qtyconop { sL1 $1 $ if isBangRdr (unLoc $1) then TyElBang else - if isTildeRdr (unLoc $1) then TyElTilde else - TyElOpr (unLoc $1) } + + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + | PREFIX_AT atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) } + + | qtyconop { sL1 $1 $ TyElOpr (unLoc $1) } | tyvarop { sL1 $1 $ TyElOpr (unLoc $1) } | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) [mj AnnSimpleQuote $1,mj AnnVal $2] } @@ -2042,6 +2056,11 @@ atype :: { LHsType GhcPs } | tyvar { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- (See Note [Unit tuples]) | '*' {% do { warnStarIsType (getLoc $1) ; return $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } } + + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + | PREFIX_TILDE atype {% ams (sLL $1 $> (mkBangTy SrcLazy $2)) [mj AnnTilde $1] } + | PREFIX_BANG atype {% ams (sLL $1 $> (mkBangTy SrcStrict $2)) [mj AnnBang $1] } + | '{' fielddecls '}' {% amms (checkRecordSyntax (sLL $1 $> $ HsRecTy noExtField $2)) -- Constructor sigs only @@ -2138,7 +2157,7 @@ fds1 :: { Located [Located (FunDep (Located RdrName))] } | fd { sL1 $1 [$1] } fd :: { Located (FunDep (Located RdrName)) } - : varids0 '->' varids0 {% ams (cL (comb3 $1 $2 $3) + : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) (reverse (unLoc $1), reverse (unLoc $3))) [mu AnnRarrow $2] } @@ -2181,13 +2200,13 @@ gadt_constrlist :: { Located ([AddAnn] ,[LConDecl GhcPs]) } -- Returned in order : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $ - cL (comb2 $1 $3) + L (comb2 $1 $3) ([mj AnnWhere $1 ,moc $2 ,mcc $4] , unLoc $3) } | 'where' vocurly gadt_constrs close {% checkEmptyGADTs $ - cL (comb2 $1 $3) + L (comb2 $1 $3) ([mj AnnWhere $1] , unLoc $3) } | {- empty -} { noLoc ([],[]) } @@ -2195,8 +2214,8 @@ gadt_constrlist :: { Located ([AddAnn] gadt_constrs :: { Located [LConDecl GhcPs] } : gadt_constr_with_doc ';' gadt_constrs {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (cL (comb2 $1 $3) ($1 : unLoc $3)) } - | gadt_constr_with_doc { cL (gl $1) [$1] } + >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } + | gadt_constr_with_doc { L (gl $1) [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -2228,12 +2247,12 @@ with constructor names (see Note [Parsing data constructors is hard]). Due to simplified syntax, GADT constructor names (left-hand side of '::') use simpler grammar production than usual data constructor names. As a -consequence, GADT constructor names are resticted (names like '(*)' are +consequence, GADT constructor names are restricted (names like '(*)' are allowed in usual data constructors, but not in GADTs). -} constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } - : maybe_docnext '=' constrs1 { cL (comb2 $2 $3) ([mj AnnEqual $2] + : maybe_docnext '=' constrs1 { L (comb2 $2 $3) ([mj AnnEqual $2] ,addConDocs (unLoc $3) $1)} constrs1 :: { Located [LConDecl GhcPs] } @@ -2297,7 +2316,7 @@ They must be kept identical except for their treatment of 'docprev'. constr :: { LConDecl GhcPs } : maybe_docnext forall constr_context '=>' constr_stuff {% ams (let (con,details,doc_prev) = unLoc $5 in - addConDoc (cL (comb4 $2 $3 $4 $5) (mkConDeclH98 con + addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con (snd $ unLoc $2) (Just $3) details)) @@ -2305,7 +2324,7 @@ constr :: { LConDecl GhcPs } (mu AnnDarrow $4:(fst $ unLoc $2)) } | maybe_docnext forall constr_stuff {% ams ( let (con,details,doc_prev) = unLoc $3 in - addConDoc (cL (comb2 $2 $3) (mkConDeclH98 con + addConDoc (L (comb2 $2 $3) (mkConDeclH98 con (snd $ unLoc $2) Nothing -- No context details)) @@ -2333,8 +2352,8 @@ fielddecls1 :: { [LConDeclField GhcPs] } fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : maybe_docnext sig_vars '::' ctype maybe_docprev - {% ams (cL (comb2 $2 $4) - (ConDeclField noExtField (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5))) + {% ams (L (comb2 $2 $4) + (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $2))) $4 ($1 `mplus` $5))) [mu AnnDcolon $3] } -- Reversed! @@ -2352,17 +2371,17 @@ derivings :: { HsDeriving GhcPs } deriving :: { LHsDerivingClause GhcPs } : 'deriving' deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField Nothing $2) + in ams (L full_loc $ HsDerivingClause noExtField Nothing $2) [mj AnnDeriving $1] } | 'deriving' deriv_strategy_no_via deriv_clause_types {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField (Just $2) $3) + in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3) [mj AnnDeriving $1] } | 'deriving' deriv_clause_types deriv_strategy_via {% let { full_loc = comb2 $1 $> } - in ams (cL full_loc $ HsDerivingClause noExtField (Just $3) $2) + in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2) [mj AnnDeriving $1] } deriv_clause_types :: { Located [LHsSigType GhcPs] } @@ -2411,25 +2430,8 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } - | '!' aexp rhs {% runECP_P $2 >>= \ $2 -> - do { let { e = patBuilderBang (getLoc $1) $2 - ; l = comb2 $1 $> }; - (ann, r) <- checkValDef SrcStrict e Nothing $3 ; - runPV $ hintBangPat (comb2 $1 $2) (unLoc e) ; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [FunBind vs PatBind] - case r of { - (FunBind _ n _ _ _) -> - amsL l [mj AnnFunId n] >> return () ; - (PatBind _ (dL->L l _) _rhs _) -> - amsL l [] >> return () } ; - - _ <- amsL l (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; - return $! (sL l $ ValD noExtField r) } } - | infixexp_top opt_sig rhs {% runECP_P $1 >>= \ $1 -> - do { (ann,r) <- checkValDef NoSrcStrict $1 (snd $2) $3; + do { (ann,r) <- checkValDef $1 (snd $2) $3; let { l = comb2 $1 $> }; -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note @@ -2437,7 +2439,7 @@ decl_no_th :: { LHsDecl GhcPs } case r of { (FunBind _ n _ _ _) -> amsL l (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind _ (dL->L lh _lhs) _rhs _) -> + (PatBind _ (L lh _lhs) _rhs _) -> amsL lh (fst $2) >> return () } ; _ <- amsL l (ann ++ (fst $ unLoc $3)); return $! (sL l $ ValD noExtField r) } } @@ -2551,8 +2553,8 @@ activation :: { ([AddAnn],Maybe Activation) } explicit_activation :: { ([AddAnn],Activation) } -- In brackets : '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3] ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } - | '[' '~' INTEGER ']' { ([mj AnnOpenS $1,mj AnnTilde $2,mj AnnVal $3 - ,mj AnnCloseS $4] + | '[' rule_activation_marker INTEGER ']' + { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4] ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) } ----------------------------------------------------------------------------- @@ -2627,66 +2629,57 @@ exp10_top :: { ECP } amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] } - - | hpc_annot exp {% runECP_P $2 >>= \ $2 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsTickPragma noExtField (snd $ fst $ fst $ unLoc $1) - (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) - (fst $ fst $ fst $ unLoc $1) } - - | '{-# CORE' STRING '#-}' exp {% runECP_P $4 >>= \ $4 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsCoreAnn noExtField (getCORE_PRAGs $1) (getStringLiteral $2) $4) - [mo $1,mj AnnVal $2 - ,mc $3] } - -- hdaume: core annotation + | exp_annot (prag_hpc) { $1 } + | exp_annot (prag_core) { $1 } | fexp { $1 } exp10 :: { ECP } : exp10_top { $1 } - | scc_annot exp {% runECP_P $2 >>= \ $2 -> - fmap ecpFromExp $ - ams (sLL $1 $> $ HsSCC noExtField (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2) - (fst $ fst $ unLoc $1) } + | exp_annot(prag_scc) { $1 } optSemi :: { ([Located Token],Bool) } : ';' { ([$1],True) } | {- empty -} { ([],False) } -scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) } +prag_scc :: { Located ([AddAnn], HsPragE GhcPs) } : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 ; return $ sLL $1 $> - (([mo $1,mj AnnValStr $2 - ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) } - | '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2 - ,mc $3],getSCC_PRAGs $1) - ,(StringLiteral NoSourceText (getVARID $2))) } - -hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), - ((SourceText,SourceText),(SourceText,SourceText)) - ) } + ([mo $1,mj AnnValStr $2,mc $3], + HsPragSCC noExtField + (getSCC_PRAGs $1) + (StringLiteral (getSTRINGs $2) scc)) } + | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3], + HsPragSCC noExtField + (getSCC_PRAGs $1) + (StringLiteral NoSourceText (getVARID $2))) } + +prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) } : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - { sLL $1 $> $ ((([mo $1,mj AnnVal $2 + { let getINT = fromInteger . il_value . getINTEGER in + sLL $1 $> $ ([mo $1,mj AnnVal $2 ,mj AnnVal $3,mj AnnColon $4 ,mj AnnVal $5,mj AnnMinus $6 ,mj AnnVal $7,mj AnnColon $8 ,mj AnnVal $9,mc $10], - getGENERATED_PRAGs $1) - ,((getStringLiteral $2) - ,( fromInteger $ il_value $ getINTEGER $3 - , fromInteger $ il_value $ getINTEGER $5 - ) - ,( fromInteger $ il_value $ getINTEGER $7 - , fromInteger $ il_value $ getINTEGER $9 - ) - )) - , (( getINTEGERs $3 - , getINTEGERs $5 - ) - ,( getINTEGERs $7 - , getINTEGERs $9 - ))) - } + HsPragTick noExtField + (getGENERATED_PRAGs $1) + (getStringLiteral $2, + (getINT $3, getINT $5), + (getINT $7, getINT $9)) + ((getINTEGERs $3, getINTEGERs $5), + (getINTEGERs $7, getINTEGERs $9) )) } + +prag_core :: { Located ([AddAnn], HsPragE GhcPs) } + : '{-# CORE' STRING '#-}' + { sLL $1 $> $ + ([mo $1,mj AnnVal $2,mc $3], + HsPragCore noExtField (getCORE_PRAGs $1) (getStringLiteral $2)) } + +exp_annot(prag) :: { ECP } + : prag exp {% runECP_P $2 >>= \ $2 -> + fmap ecpFromExp $ + ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2) + (fst $ unLoc $1) } fexp :: { ECP } : fexp aexp { ECP $ @@ -2694,11 +2687,14 @@ fexp :: { ECP } runECP_PV $1 >>= \ $1 -> runECP_PV $2 >>= \ $2 -> mkHsAppPV (comb2 $1 $>) $1 $2 } - | fexp TYPEAPP atype {% runECP_P $1 >>= \ $1 -> + + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + | fexp PREFIX_AT atype {% runECP_P $1 >>= \ $1 -> runPV (checkExpBlockArguments $1) >>= \_ -> fmap ecpFromExp $ ams (sLL $1 $> $ HsAppType noExtField $1 (mkHsWildCardBndrs $3)) [mj AnnAt $2] } + | 'static' aexp {% runECP_P $2 >>= \ $2 -> fmap ecpFromExp $ ams (sLL $1 $> $ HsStatic noExtField $2) @@ -2706,15 +2702,19 @@ fexp :: { ECP } | aexp { $1 } aexp :: { ECP } - : qvar '@' aexp { ECP $ + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + : qvar TIGHT_INFIX_AT aexp + { ECP $ runECP_PV $3 >>= \ $3 -> amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] } - -- If you change the parsing, make sure to understand - -- Note [Lexing type applications] in Lexer.x - | '~' aexp { ECP $ + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + | PREFIX_TILDE aexp { ECP $ runECP_PV $2 >>= \ $2 -> amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] } + | PREFIX_BANG aexp { ECP $ + runECP_PV $2 >>= \ $2 -> + amms (mkHsBangPatPV (comb2 $1 $>) $2) [mj AnnBang $1] } | '\\' apat apats '->' exp { ECP $ @@ -2764,7 +2764,7 @@ aexp :: { ECP } (mj AnnDo $1:(fst $ unLoc $2)) } | 'mdo' stmtlist {% runPV $2 >>= \ $2 -> fmap ecpFromExp $ - ams (cL (comb2 $1 $2) + ams (L (comb2 $1 $2) (mkHsDo MDoExpr (snd $ unLoc $2))) (mj AnnMdo $1:(fst $ unLoc $2)) } | 'proc' aexp '->' exp @@ -2812,7 +2812,7 @@ aexp2 :: { ECP } | '(#' texp '#)' { ECP $ runECP_PV $2 >>= \ $2 -> - amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [cL (gl $2) (Just $2)])) + amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)])) [mo $1,mc $3] } | '(#' tup_exprs '#)' { ECP $ $2 >>= \ $2 -> @@ -2863,22 +2863,17 @@ splice_exp :: { LHsExpr GhcPs } | splice_typed { mapLoc (HsSpliceE noExtField) $1 } splice_untyped :: { Located (HsSplice GhcPs) } - : TH_ID_SPLICE {% ams (sL1 $1 $ mkUntypedSplice HasDollar - (sL1 $1 $ HsVar noExtField (sL1 $1 (mkUnqual varName - (getTH_ID_SPLICE $1))))) - [mj AnnThIdSplice $1] } - | '$(' exp ')' {% runECP_P $2 >>= \ $2 -> - ams (sLL $1 $> $ mkUntypedSplice HasParens $2) - [mj AnnOpenPE $1,mj AnnCloseP $3] } + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + : PREFIX_DOLLAR aexp2 {% runECP_P $2 >>= \ $2 -> + ams (sLL $1 $> $ mkUntypedSplice DollarSplice $2) + [mj AnnDollar $1] } splice_typed :: { Located (HsSplice GhcPs) } - : TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkTypedSplice HasDollar - (sL1 $1 $ HsVar noExtField (sL1 $1 (mkUnqual varName - (getTH_ID_TY_SPLICE $1))))) - [mj AnnThIdTySplice $1] } - | '$$(' exp ')' {% runECP_P $2 >>= \ $2 -> - ams (sLL $1 $> $ mkTypedSplice HasParens $2) - [mj AnnOpenPTE $1,mj AnnCloseP $3] } + -- See Note [Whitespace-sensitive operator parsing] in Lexer.x + : PREFIX_DOLLAR_DOLLAR aexp2 + {% runECP_P $2 >>= \ $2 -> + ams (sLL $1 $> $ mkTypedSplice DollarSplice $2) + [mj AnnDollarDollar $1] } cmdargs :: { [LHsCmdTop GhcPs] } : cmdargs acmd { $2 : $1 } @@ -2951,7 +2946,7 @@ tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) } { $2 >>= \ $2 -> do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) ; return - ([],Tuple (map (\l -> cL l Nothing) (fst $1) ++ $2)) } } + ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } } | bars texp bars0 { runECP_PV $2 >>= \ $2 -> return $ @@ -2964,16 +2959,16 @@ commas_tup_tail : commas tup_tail do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) ; return ( (head $ fst $1 - ,(map (\l -> cL l Nothing) (tail $ fst $1)) ++ $2)) } } + ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } } -- Always follows a comma tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] } : texp commas_tup_tail { runECP_PV $1 >>= \ $1 -> $2 >>= \ $2 -> addAnnotation (gl $1) AnnComma (fst $2) >> - return ((cL (gl $1) (Just $1)) : snd $2) } + return ((L (gl $1) (Just $1)) : snd $2) } | texp { runECP_PV $1 >>= \ $1 -> - return [cL (gl $1) (Just $1)] } + return [L (gl $1) (Just $1)] } | {- empty -} { return [noLoc Nothing] } ----------------------------------------------------------------------------- @@ -2988,32 +2983,32 @@ list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) } | lexps { \loc -> $1 >>= \ $1 -> mkHsExplicitListPV loc (reverse $1) } | texp '..' { \loc -> runECP_PV $1 >>= \ $1 -> - ams (cL loc $ ArithSeq noExtField Nothing (From $1)) + ams (L loc $ ArithSeq noExtField Nothing (From $1)) [mj AnnDotdot $2] >>= ecpFromExp' } | texp ',' exp '..' { \loc -> runECP_PV $1 >>= \ $1 -> runECP_PV $3 >>= \ $3 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromThen $1 $3)) + ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3)) [mj AnnComma $2,mj AnnDotdot $4] >>= ecpFromExp' } | texp '..' exp { \loc -> runECP_PV $1 >>= \ $1 -> runECP_PV $3 >>= \ $3 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromTo $1 $3)) + ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3)) [mj AnnDotdot $2] >>= ecpFromExp' } | texp ',' exp '..' exp { \loc -> runECP_PV $1 >>= \ $1 -> runECP_PV $3 >>= \ $3 -> runECP_PV $5 >>= \ $5 -> - ams (cL loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5)) + ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5)) [mj AnnComma $2,mj AnnDotdot $4] >>= ecpFromExp' } | texp '|' flattenedpquals { \loc -> checkMonadComp >>= \ ctxt -> runECP_PV $1 >>= \ $1 -> - ams (cL loc $ mkHsComp ctxt (unLoc $3) $1) + ams (L loc $ mkHsComp ctxt (unLoc $3) $1) [mj AnnVbar $2] >>= ecpFromExp' } @@ -3048,7 +3043,7 @@ pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] } : squals '|' pquals {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } - | squals { cL (getLoc $1) [reverse (unLoc $1)] } + | squals { L (getLoc $1) [reverse (unLoc $1)] } squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last -- one can "grab" the earlier ones @@ -3061,7 +3056,7 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> ($3 : unLoc $1)) } | transformqual {% ams $1 (fst $ unLoc $1) >> - return (sLL $1 $> [cL (getLoc $1) ((snd $ unLoc $1) [])]) } + return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) } | qual {% runPV $1 >>= \ $1 -> return $ sL1 $1 [$1] } -- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } @@ -3100,7 +3095,7 @@ transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs -- Guards guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } - : guardquals1 { cL (getLoc $1) (reverse (unLoc $1)) } + : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) } guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : guardquals1 ',' qual {% runPV $3 >>= \ $3 -> @@ -3118,7 +3113,7 @@ altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Loca sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse (snd $ unLoc $2))) } | vocurly alts close { $2 >>= \ $2 -> return $ - cL (getLoc $2) (fst $ unLoc $2 + L (getLoc $2) (fst $ unLoc $2 ,(reverse (snd $ unLoc $2))) } | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) } | vocurly close { return $ noLoc ([],[]) } @@ -3194,24 +3189,14 @@ gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) } -- we parse them right when bang-patterns are off pat :: { LPat GhcPs } pat : exp {% (checkPattern <=< runECP_P) $1 } - | '!' aexp {% runECP_P $2 >>= \ $2 -> - amms (checkPattern (patBuilderBang (getLoc $1) $2)) - [mj AnnBang $1] } bindpat :: { LPat GhcPs } bindpat : exp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn checkPattern_msg (text "Possibly caused by a missing 'do'?") (runECP_PV $1) } - | '!' aexp {% -- See Note [Parser-Validator ReaderT SDoc] in RdrHsSyn - amms (checkPattern_msg (text "Possibly caused by a missing 'do'?") - (patBuilderBang (getLoc $1) `fmap` runECP_PV $2)) - [mj AnnBang $1] } apat :: { LPat GhcPs } apat : aexp {% (checkPattern <=< runECP_P) $1 } - | '!' aexp {% runECP_P $2 >>= \ $2 -> - amms (checkPattern (patBuilderBang (getLoc $1) $2)) - [mj AnnBang $1] } apats :: { [LPat GhcPs] } : apat apats { $1 : $2 } @@ -3225,7 +3210,7 @@ stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Locat sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? | vocurly stmts close { $2 >>= \ $2 -> return $ - cL (gl $2) (fst $ unLoc $2 + L (gl $2) (fst $ unLoc $2 ,reverse $ snd $ unLoc $2) } -- do { ;; s ; s ; ; s ;; } @@ -3473,7 +3458,6 @@ oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mi | '(' ':' ')' {% let { name :: Located RdrName ; name = sL1 $2 $! consDataCon_RDR } in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] } {- Note [Type constructors in export list] ~~~~~~~~~~~~~~~~~~~~~ @@ -3519,12 +3503,14 @@ qtyconsym :: { Located RdrName } tyconsym :: { Located RdrName } : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } - | VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) } + | VARSYM { sL1 $1 $! + -- See Note [eqTyCon (~) is built-in syntax] in TysWiredIn + if getVARSYM $1 == fsLit "~" + then eqTyCon_RDR + else mkUnqual tcClsName (getVARSYM $1) } | ':' { sL1 $1 $! consDataCon_RDR } | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } - | '!' { sL1 $1 $! mkUnqual tcClsName (fsLit "!") } | '.' { sL1 $1 $! mkUnqual tcClsName (fsLit ".") } - | '~' { sL1 $1 $ eqTyCon_RDR } ----------------------------------------------------------------------------- @@ -3534,7 +3520,6 @@ op :: { Located RdrName } -- used in infix decls : varop { $1 } | conop { $1 } | '->' { sL1 $1 $ getRdrName funTyCon } - | '~' { sL1 $1 $ eqTyCon_RDR } varop :: { Located RdrName } : varsym { $1 } @@ -3597,10 +3582,6 @@ var :: { Located RdrName } | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) [mop $1,mj AnnVal $2,mcp $3] } - -- Lexing type applications depends subtly on what characters can possibly - -- end a qvar. Currently (June 2015), only $idchars and ")" can end a qvar. - -- If you're changing this, please see Note [Lexing type applications] in - -- Lexer.x. qvar :: { Located RdrName } : qvarid { $1 } | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) @@ -3677,8 +3658,7 @@ special_id | 'signature' { sL1 $1 (fsLit "signature") } special_sym :: { Located FastString } -special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } - | '.' { sL1 $1 (fsLit ".") } +special_sym : '.' { sL1 $1 (fsLit ".") } | '*' { sL1 $1 (fsLit (starSym (isUnicode $1))) } ----------------------------------------------------------------------------- @@ -3785,89 +3765,87 @@ maybe_docnext :: { Maybe LHsDocString } happyError :: P a happyError = srcParseFail -getVARID (dL->L _ (ITvarid x)) = x -getCONID (dL->L _ (ITconid x)) = x -getVARSYM (dL->L _ (ITvarsym x)) = x -getCONSYM (dL->L _ (ITconsym x)) = x -getQVARID (dL->L _ (ITqvarid x)) = x -getQCONID (dL->L _ (ITqconid x)) = x -getQVARSYM (dL->L _ (ITqvarsym x)) = x -getQCONSYM (dL->L _ (ITqconsym x)) = x -getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x -getLABELVARID (dL->L _ (ITlabelvarid x)) = x -getCHAR (dL->L _ (ITchar _ x)) = x -getSTRING (dL->L _ (ITstring _ x)) = x -getINTEGER (dL->L _ (ITinteger x)) = x -getRATIONAL (dL->L _ (ITrational x)) = x -getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x -getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x -getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x -getPRIMWORD (dL->L _ (ITprimword _ x)) = x -getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x -getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x -getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x -getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x -getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) -getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) -getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x - -getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x -getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x -getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x -getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x) - -getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src -getCHARs (dL->L _ (ITchar src _)) = src -getSTRINGs (dL->L _ (ITstring src _)) = src -getPRIMCHARs (dL->L _ (ITprimchar src _)) = src -getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src -getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src -getPRIMWORDs (dL->L _ (ITprimword src _)) = src +getVARID (L _ (ITvarid x)) = x +getCONID (L _ (ITconid x)) = x +getVARSYM (L _ (ITvarsym x)) = x +getCONSYM (L _ (ITconsym x)) = x +getQVARID (L _ (ITqvarid x)) = x +getQCONID (L _ (ITqconid x)) = x +getQVARSYM (L _ (ITqvarsym x)) = x +getQCONSYM (L _ (ITqconsym x)) = x +getIPDUPVARID (L _ (ITdupipvarid x)) = x +getLABELVARID (L _ (ITlabelvarid x)) = x +getCHAR (L _ (ITchar _ x)) = x +getSTRING (L _ (ITstring _ x)) = x +getINTEGER (L _ (ITinteger x)) = x +getRATIONAL (L _ (ITrational x)) = x +getPRIMCHAR (L _ (ITprimchar _ x)) = x +getPRIMSTRING (L _ (ITprimstring _ x)) = x +getPRIMINTEGER (L _ (ITprimint _ x)) = x +getPRIMWORD (L _ (ITprimword _ x)) = x +getPRIMFLOAT (L _ (ITprimfloat x)) = x +getPRIMDOUBLE (L _ (ITprimdouble x)) = x +getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) +getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x + +getDOCNEXT (L _ (ITdocCommentNext x)) = x +getDOCPREV (L _ (ITdocCommentPrev x)) = x +getDOCNAMED (L _ (ITdocCommentNamed x)) = x +getDOCSECTION (L _ (ITdocSection n x)) = (n, x) + +getINTEGERs (L _ (ITinteger (IL src _ _))) = src +getCHARs (L _ (ITchar src _)) = src +getSTRINGs (L _ (ITstring src _)) = src +getPRIMCHARs (L _ (ITprimchar src _)) = src +getPRIMSTRINGs (L _ (ITprimstring src _)) = src +getPRIMINTEGERs (L _ (ITprimint src _)) = src +getPRIMWORDs (L _ (ITprimword src _)) = src -- See Note [Pragma source text] in BasicTypes for the following -getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src -getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src -getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src -getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src -getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src -getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src -getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src -getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src -getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src -getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src -getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src -getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src -getANN_PRAGs (dL->L _ (ITann_prag src)) = src -getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src -getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src -getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src -getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src -getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src -getCTYPEs (dL->L _ (ITctype src)) = src +getINLINE_PRAGs (L _ (ITinline_prag src _ _)) = src +getSPEC_PRAGs (L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (L _ (ITsource_prag src)) = src +getRULES_PRAGs (L _ (ITrules_prag src)) = src +getWARNING_PRAGs (L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (L _ (ITscc_prag src)) = src +getGENERATED_PRAGs (L _ (ITgenerated_prag src)) = src +getCORE_PRAGs (L _ (ITcore_prag src)) = src +getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src +getANN_PRAGs (L _ (ITann_prag src)) = src +getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src +getCTYPEs (L _ (ITctype src)) = src getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) isUnicode :: Located Token -> Bool -isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax -isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax isUnicode _ = False hasE :: Located Token -> Bool -hasE (dL->L _ (ITopenExpQuote HasE _)) = True -hasE (dL->L _ (ITopenTExpQuote HasE)) = True +hasE (L _ (ITopenExpQuote HasE _)) = True +hasE (L _ (ITopenTExpQuote HasE)) = True hasE _ = False getSCC :: Located Token -> P FastString @@ -3879,39 +3857,36 @@ getSCC lt = do let s = getSTRING lt else return s -- Utilities for combining source spans -comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan +comb2 :: Located a -> Located b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b -comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> c -> SrcSpan +comb3 :: Located a -> Located b -> Located c -> SrcSpan comb3 a b c = a `seq` b `seq` c `seq` combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) -comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) => - a -> b -> c -> d -> SrcSpan +comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan comb4 a b c d = a `seq` b `seq` c `seq` d `seq` (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ combineSrcSpans (getLoc c) (getLoc d)) -- strict constructor version: {-# INLINE sL #-} -sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a -sL span a = span `seq` a `seq` cL span a +sL :: SrcSpan -> a -> Located a +sL span a = span `seq` a `seq` L span a -- See Note [Adding location info] for how these utility functions are used -- replaced last 3 CPP macros in this file {-# INLINE sL0 #-} -sL0 :: HasSrcSpan a => SrcSpanLess a -> a -sL0 = cL noSrcSpan -- #define L0 L noSrcSpan +sL0 :: a -> Located a +sL0 = L noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} -sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b +sL1 :: Located a -> b -> Located b sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sLL #-} -sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => - a -> b -> SrcSpanLess c -> c +sLL :: Located a -> Located b -> c -> Located c sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) {- Note [Adding location info] @@ -4012,37 +3987,33 @@ in ApiAnnotation.hs -- |Construct an AddAnn from the annotation keyword and the location -- of the keyword itself -mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn +mj :: AnnKeywordId -> Located e -> AddAnn mj a l = AddAnn a (gl l) -mjL :: AnnKeywordId -> SrcSpan -> AddAnn -mjL = AddAnn - - -- |Construct an AddAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. mu :: AnnKeywordId -> Located Token -> AddAnn -mu a lt@(dL->L l t) = AddAnn (toUnicodeAnn a lt) l +mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a -gl :: HasSrcSpan a => a -> SrcSpan +gl :: Located a -> SrcSpan gl = getLoc -- |Add an annotation to the located element, and return the located -- element as a pass through -aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a -aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a +aa :: Located a -> (AnnKeywordId, Located c) -> P (Located a) +aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a -- |Add an annotation to a located element resulting from a monadic action -am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a +am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) am a (b,s) = do - av@(dL->L l _) <- a + av@(L l _) <- a addAnnotation l b (gl s) return av @@ -4059,27 +4030,27 @@ am a (b,s) = do -- as any annotations that may arise in the binds. This will include open -- and closing braces if they are used to delimit the let expressions. -- -ams :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m a -ams a@(dL->L l _) bs = addAnnsAt l bs >> return a +ams :: MonadP m => Located a -> [AddAnn] -> m (Located a) +ams a@(L l _) bs = addAnnsAt l bs >> return a amsL :: SrcSpan -> [AddAnn] -> P () amsL sp bs = addAnnsAt sp bs >> return () -- |Add all [AddAnn] to an AST element, and wrap it in a 'Just' -ajs :: (MonadP m, HasSrcSpan a) => a -> [AddAnn] -> m (Maybe a) +ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a)) ajs a bs = Just <$> ams a bs -- |Add a list of AddAnns to the given AST element, where the AST element is the -- result of a monadic action -amms :: MonadP m => HasSrcSpan a => m a -> [AddAnn] -> m a -amms a bs = do { av@(dL->L l _) <- a +amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a) +amms a bs = do { av@(L l _) <- a ; addAnnsAt l bs ; return av } -- |Add a list of AddAnns to the AST element, and return the element as a -- OrdList -amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a) -amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a) +amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) +amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) -- |Synonyms for AddAnn versions of AnnOpen and AnnClose mo,mc :: Located Token -> AddAnn @@ -4101,22 +4072,22 @@ mcs ll = mj AnnCloseS ll -- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma -- entry for each SrcSpan mcommas :: [SrcSpan] -> [AddAnn] -mcommas ss = map (mjL AnnCommaTuple) ss +mcommas = map (AddAnn AnnCommaTuple) -- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar -- entry for each SrcSpan mvbars :: [SrcSpan] -> [AddAnn] -mvbars ss = map (mjL AnnVbar) ss +mvbars = map (AddAnn AnnVbar) -- |Get the location of the last element of a OrdList, or noSrcSpan -oll :: HasSrcSpan a => OrdList a -> SrcSpan +oll :: OrdList (Located a) -> SrcSpan oll l = if isNilOL l then noSrcSpan else getLoc (lastOL l) -- |Add a semicolon annotation in the right place in a list. If the -- leading list is empty, add it to the tail -asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P() -asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls -asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls +asl :: [Located a] -> Located b -> Located a -> P () +asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls +asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index cb70078fd3..0ffad547a7 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -56,8 +56,6 @@ module RdrHsSyn ( checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat checkPattern_msg, - isBangRdr, - isTildeRdr, checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs, @@ -68,6 +66,7 @@ module RdrHsSyn ( checkEmptyGADTs, addFatalError, hintBangPat, TyEl(..), mergeOps, mergeDataCon, + mkBangTy, -- Help with processing exports ImpExpSubSpec(..), @@ -100,7 +99,6 @@ module RdrHsSyn ( ecpFromExp, ecpFromCmd, PatBuilder, - patBuilderBang, ) where @@ -162,10 +160,10 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) -- *** See Note [The Naming story] in GHC.Hs.Decls **** mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d) +mkTyClD (L loc d) = L loc (TyClD noExtField d) mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkInstD (dL->L loc d) = cL loc (InstD noExtField d) +mkInstD (L loc d) = L loc (InstD noExtField d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -173,21 +171,21 @@ mkClassDecl :: SrcSpan -> OrdList (LHsDecl GhcPs) -> P (LTyClDecl GhcPs) -mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls +mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; return (cL loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt - , tcdLName = cls, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdFDs = snd (unLoc fds) - , tcdSigs = mkClassOpSigs sigs - , tcdMeths = binds - , tcdATs = ats, tcdATDefs = at_defs - , tcdDocs = docs })) } + ; return (L loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt + , tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } mkTyData :: SrcSpan -> NewOrData @@ -197,17 +195,17 @@ mkTyData :: SrcSpan -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LTyClDecl GhcPs) -mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) +mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (cL loc (DataDecl { tcdDExt = noExtField, - tcdLName = tc, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn })) } + ; return (L loc (DataDecl { tcdDExt = noExtField, + tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn })) } mkDataDefn :: NewOrData -> Maybe (Located CType) @@ -236,10 +234,10 @@ mkTySynonym loc lhs rhs ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (cL loc (SynDecl { tcdSExt = noExtField - , tcdLName = tc, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdRhs = rhs })) } + ; return (L loc (SynDecl { tcdSExt = noExtField + , tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdRhs = rhs })) } mkStandaloneKindSig :: SrcSpan @@ -249,7 +247,7 @@ mkStandaloneKindSig mkStandaloneKindSig loc lhs rhs = do { vs <- mapM check_lhs_name (unLoc lhs) ; v <- check_singular_lhs (reverse vs) - ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } + ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } where check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) @@ -294,7 +292,7 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs + ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs (FamEqn { feqn_ext = noExtField , feqn_tycon = tc , feqn_bndrs = bndrs @@ -306,7 +304,7 @@ mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs) mkTyFamInst loc eqn - = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn))) + = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs @@ -319,7 +317,7 @@ mkFamDecl loc info lhs ksig injAnn ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (cL loc (FamDecl noExtField (FamilyDecl + ; return (L loc (FamDecl noExtField (FamilyDecl { fdExt = noExtField , fdInfo = info, fdLName = tc , fdTyVars = tyvars @@ -342,15 +340,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 -mkSpliceDecl lexpr@(dL->L loc expr) +mkSpliceDecl lexpr@(L loc expr) | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) + = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) + = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) | otherwise - = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice NoParens lexpr)) + = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan @@ -359,16 +357,16 @@ mkRoleAnnotDecl :: SrcSpan -> P (LRoleAnnotDecl GhcPs) mkRoleAnnotDecl loc tycon roles = do { roles' <- mapM parse_role roles - ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' } + ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type possible_roles = [(fsFromRole role, role) | role <- all_roles] - parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing - parse_role (dL->L loc_role (Just role)) + parse_role (L loc_role Nothing) = return $ L loc_role Nothing + parse_role (L loc_role (Just role)) = case lookup role possible_roles of - Just found_role -> return $ cL loc_role $ Just found_role + Just found_role -> return $ L loc_role $ Just found_role Nothing -> let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) @@ -376,8 +374,6 @@ mkRoleAnnotDecl loc tycon roles addFatalError loc_role (text "Illegal role name" <+> quotes (ppr role) $$ suggestions nearby) - parse_role _ = panic "parse_role: Impossible Match" - -- due to #15884 suggestions [] = empty suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) @@ -402,9 +398,9 @@ cvTopDecls decls = go (fromOL decls) where go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] go [] = [] - go ((dL->L l (ValD x b)) : ds) - = cL l' (ValD x b') : go ds' - where (dL->L l' b', ds') = getMonoBind (cL l b) ds + go ((L l (ValD x b)) : ds) + = L l' (ValD x b') : go ds' + where (L l' b', ds') = getMonoBind (L l b) ds go (d : ds) = d : go ds -- Declaration list may only contain value bindings and signatures. @@ -424,24 +420,24 @@ cvBindsAndSigs :: OrdList (LHsDecl GhcPs) cvBindsAndSigs fb = go (fromOL fb) where go [] = return (emptyBag, [], [], [], [], []) - go ((dL->L l (ValD _ b)) : ds) + go ((L l (ValD _ b)) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } where - (b', ds') = getMonoBind (cL l b) ds - go ((dL->L l decl) : ds) + (b', ds') = getMonoBind (L l b) ds + go ((L l decl) : ds) = do { (bs, ss, ts, tfis, dfis, docs) <- go ds ; case decl of SigD _ s - -> return (bs, cL l s : ss, ts, tfis, dfis, docs) + -> return (bs, L l s : ss, ts, tfis, dfis, docs) TyClD _ (FamDecl _ t) - -> return (bs, ss, cL l t : ts, tfis, dfis, docs) + -> return (bs, ss, L l t : ts, tfis, dfis, docs) InstD _ (TyFamInstD { tfid_inst = tfi }) - -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs) + -> return (bs, ss, ts, L l tfi : tfis, dfis, docs) InstD _ (DataFamInstD { dfid_inst = dfi }) - -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs) + -> return (bs, ss, ts, tfis, L l dfi : dfis, docs) DocD _ d - -> return (bs, ss, ts, tfis, dfis, cL l d : docs) + -> return (bs, ss, ts, tfis, dfis, L l d : docs) SpliceD _ d -> addFatalError l $ hang (text "Declaration splices are allowed only" <+> @@ -467,25 +463,25 @@ getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) - , fun_matches = - MG { mg_alts = (dL->L _ mtchs1) } })) +getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) + , fun_matches = + MG { mg_alts = (L _ mtchs1) } })) binds | has_args mtchs1 = go mtchs1 loc1 binds [] where go mtchs loc - ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) - , fun_matches = - MG { mg_alts = (dL->L _ mtchs2) } }))) + ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2) + , fun_matches = + MG { mg_alts = (L _ mtchs2) } }))) : binds) _ | f1 == f2 = go (mtchs2 ++ mtchs) (combineSrcSpans loc loc2) binds [] - go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls + go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls = let doc_decls' = doc_decl : doc_decls in go mtchs (combineSrcSpans loc loc2) binds doc_decls' go mtchs loc binds doc_decls - = ( cL loc (makeFunBind fun_id1 (reverse mtchs)) + = ( L loc (makeFunBind fun_id1 (reverse mtchs)) , (reverse doc_decls) ++ binds) -- Reverse the final matches, to get it back in the right order -- Do the same thing with the trailing doc comments @@ -493,14 +489,13 @@ getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) getMonoBind bind binds = (bind, binds) has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool -has_args [] = panic "RdrHsSyn:has_args" -has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) +has_args [] = panic "RdrHsSyn:has_args" +has_args (L _ (Match { m_pats = args }) : _) = not (null args) -- Don't group together FunBinds if they have -- 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). -has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec -has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 +has_args (L _ (XMatch nec) : _) = noExtCon nec {- ********************************************************************** @@ -564,14 +559,13 @@ declarations and types as a reversed list of TyEl: data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) - | TyElBang | TyElTilde | ... -For example, both occurences of (C ! D) in the following example are parsed +For example, both occurrences of (C ! D) in the following example are parsed into equal lists of TyEl: data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D") - , TyElBang + , TyElOpr "!" , TyElOpd (HsTyVar "C") ] Note that elements are in reverse order. Also, 'C' is parsed as a type @@ -592,7 +586,7 @@ tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) tyConToDataCon loc tc | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) - = return (cL loc (setRdrNameSpace tc srcDataName)) + = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise = Left (loc, msg) @@ -603,14 +597,14 @@ tyConToDataCon loc tc mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = +mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = do { matches <- mapM fromDecl (fromOL decls) ; when (null matches) (wrongNumberErr loc) ; return $ mkMatchGroup FromSource matches } where - fromDecl (dL->L loc decl@(ValD _ (PatBind _ - pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) - rhs _))) = + fromDecl (L loc decl@(ValD _ (PatBind _ + pat@(L _ (ConPatIn ln@(L _ name) details)) + rhs _))) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of @@ -632,8 +626,8 @@ mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = , mc_strictness = NoSrcStrict } RecCon{} -> recordPatSynErr loc pat - ; return $ cL loc match } - fromDecl (dL->L loc decl) = extraDeclErr loc decl + ; return $ L loc match } + fromDecl (L loc decl) = extraDeclErr loc decl extraDeclErr loc decl = addFatalError loc $ @@ -675,7 +669,7 @@ mkGadtDecl :: [Located RdrName] mkGadtDecl names ty = (ConDeclGADT { con_g_ext = noExtField , con_names = names - , con_forall = cL l $ isLHsForAllTy ty' + , con_forall = L l $ isLHsForAllTy ty' , con_qvars = mkHsQTvs tvs , con_mb_cxt = mcxt , con_args = args @@ -683,13 +677,13 @@ mkGadtDecl names ty , con_doc = Nothing } , anns1 ++ anns2) where - (ty'@(dL->L l _),anns1) = peel_parens ty [] + (ty'@(L l _),anns1) = peel_parens ty [] (tvs, rho) = splitLHsForAllTyInvis ty' (mcxt, tau, anns2) = split_rho rho [] - split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann + split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann = (Just cxt, tau, ann) - split_rho (dL->L l (HsParTy _ ty)) ann + split_rho (L l (HsParTy _ ty)) ann = split_rho ty (ann++mkParensApiAnn l) split_rho tau ann = (Nothing, tau, ann) @@ -697,12 +691,12 @@ mkGadtDecl names ty (args, res_ty) = split_tau tau -- See Note [GADT abstract syntax] in GHC.Hs.Decls - split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) - = (RecCon (cL loc rf), res_ty) + split_tau (L _ (HsFunTy _ (L loc (HsRecTy _ rf)) res_ty)) + = (RecCon (L loc rf), res_ty) split_tau tau = (PrefixCon [], tau) - peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty + peel_parens (L l (HsParTy _ ty)) ann = peel_parens ty (ann++mkParensApiAnn l) peel_parens ty ann = (ty, ann) @@ -826,19 +820,18 @@ checkTyVars pp_what equals_or_where tc tparms -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr GhcPs, [AddAnn]) - chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l - ++ acc) ty + chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty chkParens acc ty = do tv <- chk ty return (tv, reverse acc) -- Check that the name space is correct! chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs) - chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) - | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k)) - chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) - | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv))) - chk t@(dL->L loc _) + chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) + | isRdrTyVar tv = return (L l (KindedTyVar noExtField (L lv tv) k)) + chk (L l (HsTyVar _ _ (L ltv tv))) + | isRdrTyVar tv = return (L l (UserTyVar noExtField (L ltv tv))) + chk t@(L loc _) = addFatalError loc $ vcat [ text "Unexpected type" <+> quotes (ppr t) , text "In the" <+> pp_what @@ -896,14 +889,14 @@ mkRuleTyVarBndrs = fmap (fmap cvt_one) -- See note [Parsing explicit foralls in Rules] in Parser.y checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) - where check (dL->L loc (Unqual occ)) = do + where check (L loc (Unqual occ)) = do when ((occNameString occ ==) `any` ["forall","family","role"]) (addFatalError loc (text $ "parse error on input " ++ occNameString occ)) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) -checkRecordSyntax lr@(dL->L loc r) +checkRecordSyntax lr@(L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit unless allowed $ addError loc $ text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r @@ -913,7 +906,7 @@ checkRecordSyntax lr@(dL->L loc r) -- `data T where` to avoid affecting existing error message, see #8258. checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs])) -checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. +checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax unless gadtSyntax $ addError span $ vcat [ text "Illegal keyword 'where' in data declaration" @@ -937,23 +930,23 @@ checkTyClHdr :: Bool -- True <=> class header checkTyClHdr is_cls ty = goL ty [] [] Prefix where - goL (dL->L l ty) acc ann fix = go l ty acc ann fix + goL (L l ty) acc ann fix = go l ty acc ann fix -- workaround to define '*' despite StarIsType - go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix + go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix = do { warnStarBndr l ; let name = mkOccName tcClsName (starSym isUni) - ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } + ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } - go _ (HsTyVar _ _ ltc@(dL->L _ tc)) acc ann fix + go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix | isRdrTc tc = return (ltc, acc, fix, ann) - go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix + go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann) go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix - = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann) + = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity @@ -990,7 +983,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () HsCmdDo {} -> check "do command" cmd _ -> return () - check :: (HasSrcSpan a, Outputable a) => String -> a -> PV () + check :: Outputable a => String -> Located a -> PV () check element a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ @@ -1010,22 +1003,22 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () -- (((Eq a))) --> [Eq a] -- @ checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) -checkContext (dL->L l orig_t) - = check [] (cL l orig_t) +checkContext (L l orig_t) + = check [] (L l orig_t) where - check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) + check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. - = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto () + = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () - check anns (dL->L lp1 (HsParTy _ ty)) + check anns (L lp1 (HsParTy _ ty)) -- to be sure HsParTy doesn't get into the way = check anns' ty where anns' = if l == lp1 then anns else (anns ++ mkParensApiAnn lp1) -- no need for anns, returning original - check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t]) + check _anns t = checkNoDocs msg t *> return ([],L l [L l orig_t]) msg = text "data constructor context" @@ -1034,9 +1027,9 @@ checkContext (dL->L l orig_t) checkNoDocs :: SDoc -> LHsType GhcPs -> P () checkNoDocs msg ty = go ty where - go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki - go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 - go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep + go (L _ (HsAppKindTy _ ty ki)) = go ty *> go ki + go (L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 + go (L l (HsDocTy _ t ds)) = addError l $ hsep [ text "Unexpected haddock", quotes (ppr ds) , text "on", msg, quotes (ppr t) ] go _ = pure () @@ -1079,27 +1072,21 @@ checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat) checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) -checkLPat e@(dL->L l _) = checkPat l e [] +checkLPat e@(L l _) = checkPat l e [] checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] -> PV (LPat GhcPs) -checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args - | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) +checkPat loc (L l e@(PatBuilderVar (L _ c))) args + | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) | not (null args) && patIsRec c = localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ patFail l (ppr e) -checkPat loc e args -- OK to let this happen even if bang-patterns - -- are not enabled, because there is no valid - -- non-bang-pattern parse of (C ! e) - | Just (e', args') <- splitBang e - = do { args'' <- mapM checkLPat args' - ; checkPat loc e' (args'' ++ args) } -checkPat loc (dL->L _ (PatBuilderApp f e)) args +checkPat loc (L _ (PatBuilderApp f e)) args = do p <- checkLPat e checkPat loc f (p : args) -checkPat loc (dL->L _ e) [] +checkPat loc (L _ e) [] = do p <- checkAPat loc e - return (cL loc p) + return (L loc p) checkPat loc e _ = patFail loc (ppr e) @@ -1113,27 +1100,21 @@ checkAPat loc e0 = do -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) - - PatBuilderBang lb e -- (! x) - -> do { hintBangPat loc e0 - ; e' <- checkLPat e - ; addAnnotation loc AnnBang lb - ; return (BangPat noExtField e') } + PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) -- n+k patterns PatBuilderOpApp - (dL->L nloc (PatBuilderVar (dL->L _ n))) - (dL->L _ plus) - (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + (L nloc (PatBuilderVar (L _ n))) + (L _ plus) + (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) | nPlusKPatterns && (plus == plus_RDR) - -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) + -> return (mkNPlusKPat (L nloc n) (L lloc lit)) - PatBuilderOpApp l (dL->L cl c) r + PatBuilderOpApp l (L cl c) r | isRdrDataCon c -> do l <- checkLPat l r <- checkLPat r - return (ConPatIn (cL cl c) (InfixCon l r)) + return (ConPatIn (L cl c) (InfixCon l r)) PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) _ -> patFail loc (ppr e0) @@ -1148,15 +1129,10 @@ plus_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -isBangRdr, isTildeRdr :: RdrName -> Bool -isBangRdr (Unqual occ) = occNameFS occ == fsLit "!" -isBangRdr _ = False -isTildeRdr = (==eqTyCon_RDR) - checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) -checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld) - return (cL l (fld { hsRecFieldArg = p })) +checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld) + return (L l (fld { hsRecFieldArg = p })) patFail :: SrcSpan -> SDoc -> PV a patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e @@ -1167,23 +1143,22 @@ patIsRec e = e == mkUnqual varName (fsLit "rec") --------------------------------------------------------------------------- -- Check Equation Syntax -checkValDef :: SrcStrictness - -> Located (PatBuilder GhcPs) +checkValDef :: Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkValDef _strictness lhs (Just sig) grhss +checkValDef lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat checkPatBind lhs' grhss -checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) +checkValDef lhs Nothing g@(L l (_,grhss)) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> - checkFunBind strictness ann (getLoc lhs) - fun is_infix pats (cL l grhss) + checkFunBind NoSrcStrict ann (getLoc lhs) + fun is_infix pats (L l grhss) Nothing -> do lhs' <- checkPattern lhs checkPatBind lhs' g } @@ -1196,19 +1171,19 @@ checkFunBind :: SrcStrictness -> [Located (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) +checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) = do ps <- mapM checkPattern pats let match_span = combineSrcSpans lhs_loc rhs_span -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann return (ann, makeFunBind fun - [cL match_span (Match { m_ext = noExtField - , m_ctxt = FunRhs - { mc_fun = fun - , mc_fixity = is_infix - , mc_strictness = strictness } - , m_pats = ps - , m_grhss = grhss })]) + [L match_span (Match { m_ext = noExtField + , m_ctxt = FunRhs + { mc_fun = fun + , mc_fixity = is_infix + , mc_strictness = strictness } + , m_pats = ps + , m_grhss = grhss })]) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. @@ -1222,19 +1197,32 @@ makeFunBind fn ms fun_co_fn = idHsWrapper, fun_tick = [] } +-- See Note [FunBind vs PatBind] checkPatBind :: LPat GhcPs -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) -checkPatBind lhs (dL->L _ (_,grhss)) +checkPatBind lhs (L match_span (_,grhss)) + | BangPat _ p <- unLoc lhs + , VarPat _ v <- unLoc p + = return ([], makeFunBind v [L match_span (m v)]) + where + m v = Match { m_ext = noExtField + , m_ctxt = FunRhs { mc_fun = L (getLoc lhs) (unLoc v) + , mc_fixity = Prefix + , mc_strictness = SrcStrict } + , m_pats = [] + , m_grhss = grhss } + +checkPatBind lhs (L _ (_,grhss)) = return ([],PatBind noExtField lhs grhss ([],[])) checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) -checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) +checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr -checkValSigLhs lhs@(dL->L l _) +checkValSigLhs lhs@(L l _) = addFatalError l ((text "Invalid type signature:" <+> ppr lhs <+> text ":: ...") $$ text hint) @@ -1252,8 +1240,8 @@ checkValSigLhs lhs@(dL->L l _) -- so check for that, and suggest. cf #3805 -- Sadly 'foreign import' still barfs 'parse error' because -- 'import' is a keyword - looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s - looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs + looks_like s (L _ (HsVar _ (L _ v))) = v == s + looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") @@ -1261,8 +1249,8 @@ checkValSigLhs lhs@(dL->L l _) pattern_RDR = mkUnqual varName (fsLit "pattern") checkDoAndIfThenElse - :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) - => a -> Bool -> b -> Bool -> c -> PV () + :: (Outputable a, Outputable b, Outputable c) + => Located a -> Bool -> b -> Bool -> Located c -> PV () checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do doAndIfThenElse <- getBit DoAndIfThenElseBit @@ -1278,77 +1266,27 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> text "else" <+> ppr elseExpr - - -- The parser left-associates, so there should - -- not be any OpApps inside the e's -splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) --- Splits (f ! g a b) into (f, [(! g), a, b]) -splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg)) - | isBangRdr (unLoc op) - = Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns) - where - l' = combineLocs op arg1 - (arg1,argns) = split_bang r_arg [] - split_bang (dL->L _ (PatBuilderApp f e)) es = split_bang f (e:es) - split_bang e es = (e,es) -splitBang _ = Nothing - --- See Note [isFunLhs vs mergeDataCon] isFunLhs :: Located (PatBuilder GhcPs) -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS --- --- The whole LHS is parsed as a single expression. --- Any infix operators on the LHS will parse left-associatively --- E.g. f !x y !z --- will parse (rather strangely) as --- (f ! x y) ! z --- It's up to isFunLhs to sort out the mess --- --- a .!. !b - isFunLhs e = go e [] [] where - go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann - | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) - go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann - go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) - - -- Things of the form `!x` are also FunBinds - -- See Note [FunBind vs PatBind] - go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann - | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) - - -- For infix function defns, there should be only one infix *function* - -- (though there may be infix *datacons* involved too). So we don't - -- need fixity info to figure out which function is being defined. - -- a `K1` b `op` c `K2` d - -- must parse as - -- (a `K1` b) `op` (c `K2` d) - -- The renamer checks later that the precedences would yield such a parse. - -- - -- There is a complication to deal with bang patterns. - -- - -- ToDo: what about this? - -- x + 1 `op` y = ... - - go e@(L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann - | Just (e',es') <- splitBang e - = do { bang_on <- getBit BangPatBit - ; if bang_on then go e' (es' ++ es) ann - else return (Just (cL loc' op, Infix, (l:r:es), ann)) } - -- No bangs; behave just like the next case + go (L loc (PatBuilderVar (L _ f))) es ann + | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) + go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann + go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann | not (isRdrDataCon op) -- We have found the function! - = return (Just (cL loc' op, Infix, (l:r:es), ann)) + = return (Just (L loc' op, Infix, (l:r:es), ann)) | otherwise -- Infix data con; keep going = do { mb_l <- go l es ann ; case mb_l of Just (op', Infix, j : k : es', ann') -> return (Just (op', Infix, j : op_app : es', ann')) where - op_app = cL loc (PatBuilderOpApp k - (cL loc' op) r) + op_app = L loc (PatBuilderOpApp k + (L loc' op) r) _ -> return Nothing } go _ _ _ = return Nothing @@ -1356,7 +1294,6 @@ isFunLhs e = go e [] [] data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) | TyElKindApp SrcSpan (LHsType GhcPs) -- See Note [TyElKindApp SrcSpan interpretation] - | TyElTilde | TyElBang | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) | TyElDocPrev HsDocString @@ -1379,40 +1316,22 @@ instance Outputable TyEl where ppr (TyElOpr name) = ppr name ppr (TyElOpd ty) = ppr ty ppr (TyElKindApp _ ki) = text "@" <> ppr ki - ppr TyElTilde = text "~" - ppr TyElBang = text "!" ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk ppr (TyElDocPrev doc) = ppr doc -tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness) -tyElStrictness TyElTilde = Just (AnnTilde, SrcLazy) -tyElStrictness TyElBang = Just (AnnBang, SrcStrict) -tyElStrictness _ = Nothing - -- | Extract a strictness/unpackedness annotation from the front of a reversed -- 'TyEl' list. -pStrictMark +pUnpackedness :: [Located TyEl] -- reversed TyEl - -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -} + -> Maybe ( SrcSpan , [AddAnn] + , SourceText + , SrcUnpackedness , [Located TyEl] {- remaining TyEl -}) -pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs) - | Just (strAnnId, str) <- tyElStrictness x1 - , TyElUnpackedness (unpkAnns, prag, unpk) <- x2 - = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) - , unpkAnns ++ [AddAnn strAnnId l1] - , xs ) -pStrictMark ((dL->L l x1) : xs) - | Just (strAnnId, str) <- tyElStrictness x1 - = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str) - , [AddAnn strAnnId l] - , xs ) -pStrictMark ((dL->L l x1) : xs) +pUnpackedness (L l x1 : xs) | TyElUnpackedness (anns, prag, unpk) <- x1 - = Just ( cL l (HsSrcBang prag unpk NoSrcStrict) - , anns - , xs ) -pStrictMark _ = Nothing + = Just (l, anns, prag, unpk, xs) +pUnpackedness _ = Nothing pBangTy :: LHsType GhcPs -- a type to be wrapped inside HsBangTy @@ -1421,13 +1340,24 @@ pBangTy , LHsType GhcPs {- the resulting BangTy -} , P () {- add annotations -} , [Located TyEl] {- remaining TyEl -}) -pBangTy lt@(dL->L l1 _) xs = - case pStrictMark xs of +pBangTy lt@(L l1 _) xs = + case pUnpackedness xs of Nothing -> (False, lt, pure (), xs) - Just (dL->L l2 strictMark, anns, xs') -> + Just (l2, anns, prag, unpk, xs') -> let bl = combineSrcSpans l1 l2 - bt = HsBangTy noExtField strictMark lt - in (True, cL bl bt, addAnnsAt bl anns, xs') + bt = addUnpackedness (prag, unpk) lt + in (True, L bl bt, addAnnsAt bl anns, xs') + +mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs +mkBangTy strictness = + HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness) + +addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> HsType GhcPs +addUnpackedness (prag, unpk) (L _ (HsBangTy x bang t)) + | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang + = HsBangTy x (HsSrcBang prag unpk strictness) t +addUnpackedness (prag, unpk) t + = HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t -- | Merge a /reversed/ and /non-empty/ soup of operators and operands -- into a type. @@ -1442,8 +1372,8 @@ pBangTy lt@(dL->L l1 _) xs = -- -- See Note [Parsing data constructors is hard] mergeOps :: [Located TyEl] -> P (LHsType GhcPs) -mergeOps ((dL->L l1 (TyElOpd t)) : xs) - | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs +mergeOps ((L l1 (TyElOpd t)) : xs) + | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs , null xs' -- We accept a BangTy only when there are no preceding TyEl. = addAnns >> return t' mergeOps all_xs = go (0 :: Int) [] id all_xs @@ -1453,7 +1383,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [unpk]: -- handle (NO)UNPACK pragmas - go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = + go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = if not (null acc) && null xs then do { acc' <- eitherToP $ mergeOpsAcc acc ; let a = ops_acc acc' @@ -1461,7 +1391,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs bl = combineSrcSpans l (getLoc a) bt = HsBangTy noExtField strictMark a ; addAnnsAt bl anns - ; return (cL bl bt) } + ; return (L bl bt) } else addFatalError l unpkError where unpkSDoc = case unpkSrc of @@ -1476,68 +1406,35 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [doc]: -- we do not expect to encounter any docs - go _ _ _ ((dL->L l (TyElDocPrev _)):_) = + go _ _ _ ((L l (TyElDocPrev _)):_) = failOpDocPrev l - -- to improve error messages, we do a bit of guesswork to determine if the - -- user intended a '!' or a '~' as a strictness annotation - go k acc ops_acc ((dL->L l x) : xs) - | Just (_, str) <- tyElStrictness x - , let guess [] = True - guess ((dL->L _ (TyElOpd _)):_) = False - guess ((dL->L _ (TyElOpr _)):_) = True - guess ((dL->L _ (TyElKindApp _ _)):_) = False - guess ((dL->L _ (TyElTilde)):_) = True - guess ((dL->L _ (TyElBang)):_) = True - guess ((dL->L _ (TyElUnpackedness _)):_) = True - guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs' - guess _ = panic "mergeOps.go.guess: Impossible Match" - -- due to #15884 - in guess xs - = if not (null acc) && (k > 1 || length acc > 1) - then do { a <- eitherToP (mergeOpsAcc acc) - ; failOpStrictnessCompound (cL l str) (ops_acc a) } - else failOpStrictnessPosition (cL l str) - -- clause [opr]: -- when we encounter an operator, we must have accumulated -- something for its rhs, and there must be something left -- to build its lhs. - go k acc ops_acc ((dL->L l (TyElOpr op)):xs) = + go k acc ops_acc ((L l (TyElOpr op)):xs) = if null acc || null (filter isTyElOpd xs) - then failOpFewArgs (cL l op) + then failOpFewArgs (L l op) else do { acc' <- eitherToP (mergeOpsAcc acc) - ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs } + ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs } where - isTyElOpd (dL->L _ (TyElOpd _)) = True + isTyElOpd (L _ (TyElOpd _)) = True isTyElOpd _ = False - -- clause [opr.1]: interpret 'TyElTilde' as an operator - go k acc ops_acc ((dL->L l TyElTilde):xs) = - let op = eqTyCon_RDR - in go k acc ops_acc (cL l (TyElOpr op):xs) - - -- clause [opr.2]: interpret 'TyElBang' as an operator - go k acc ops_acc ((dL->L l TyElBang):xs) = - let op = mkUnqual tcClsName (fsLit "!") - in go k acc ops_acc (cL l (TyElOpr op):xs) - -- clause [opd]: -- whenever an operand is encountered, it is added to the accumulator - go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs + go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs -- clause [tyapp]: -- whenever a type application is encountered, it is added to the accumulator - go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs + go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs -- clause [end] -- See Note [Non-empty 'acc' in mergeOps clause [end]] go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc) ; return (ops_acc acc') } - go _ _ _ _ = panic "mergeOps.go: Impossible Match" - -- due to #15884 - mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> Either (SrcSpan, SDoc) (LHsType GhcPs) mergeOpsAcc [] = panic "mergeOpsAcc: empty input" @@ -1609,8 +1506,8 @@ Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause -} pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) -pInfixSide ((dL->L l (TyElOpd t)):xs) - | (True, t', addAnns, xs') <- pBangTy (cL l t) xs +pInfixSide ((L l (TyElOpd t)):xs) + | (True, t', addAnns, xs') <- pBangTy (L l t) xs = Just (t', addAnns, xs') pInfixSide (el:xs1) | Just t1 <- pLHsTypeArg el @@ -1627,84 +1524,29 @@ pInfixSide (el:xs1) pInfixSide _ = Nothing pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs)) -pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a)) -pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a) +pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a)) +pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a) pLHsTypeArg _ = Nothing pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) pDocPrev = go Nothing where - go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) = - go (mTrailingDoc `mplus` Just (cL l doc)) xs + go mTrailingDoc ((L l (TyElDocPrev doc)):xs) = + go (mTrailingDoc `mplus` Just (L l doc)) xs go mTrailingDoc xs = (mTrailingDoc, xs) orErr :: Maybe a -> b -> Either b a orErr (Just a) _ = Right a orErr Nothing b = Left b -{- Note [isFunLhs vs mergeDataCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When parsing a function LHS, we do not know whether to treat (!) as -a strictness annotation or an infix operator: - - f ! a = ... - -Without -XBangPatterns, this parses as (!) f a = ... - with -XBangPatterns, this parses as f (!a) = ... - -So in function declarations we opted to always parse as if -XBangPatterns -were off, and then rejig in 'isFunLhs'. - -There are two downsides to this approach: - -1. It is not particularly elegant, as there's a point in our pipeline where - the representation is awfully incorrect. For instance, - f !a b !c = ... - will be first parsed as - (f ! a b) ! c = ... - -2. There are cases that it fails to cover, for instance infix declarations: - !a + !b = ... - will trigger an error. - -Unfortunately, we cannot define different productions in the 'happy' grammar -depending on whether -XBangPatterns are enabled. - -When parsing data constructors, we face a similar issue: - (a) data T1 = C ! D - (b) data T2 = C ! D => ... - -In (a) the first bang is a strictness annotation, but in (b) it is a type -operator. A 'happy'-based parser does not have unlimited lookahead to check for -=>, so we must first parse (C ! D) into a common representation. - -If we tried to mirror the approach used in functions, we would parse both sides -of => as types, and then rejig. However, we take a different route and use an -intermediate data structure, a reversed list of 'TyEl'. -See Note [Parsing data constructors is hard] for details. - -This approach does not suffer from the issues of 'isFunLhs': - -1. A sequence of 'TyEl' is a dedicated intermediate representation, not an - incorrectly parsed type. Therefore, we do not have confusing states in our - pipeline. (Except for representing data constructors as type variables). - -2. We can handle infix data constructors with strictness annotations: - data T a b = !a :+ !b - --} - - -- | Merge a /reversed/ and /non-empty/ soup of operators and operands -- into a data constructor. -- -- User input: @C !A B -- ^ doc@ --- Input to 'mergeDataCon': ["doc", B, !, A, C] +-- Input to 'mergeDataCon': ["doc", B, !A, C] -- Output: (C, PrefixCon [!A, B], "doc") -- -- See Note [Parsing data constructors is hard] --- See Note [isFunLhs vs mergeDataCon] mergeDataCon :: [Located TyEl] -> P ( Located RdrName -- constructor name @@ -1733,7 +1575,7 @@ mergeDataCon all_xs = -- A -- ^ Comment on A -- B -- ^ Comment on B (singleDoc == False) singleDoc = isJust mTrailingDoc && - null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ] + null [ () | (L _ (TyElDocPrev _)) <- all_xs' ] -- The result of merging the list of reversed TyEl into a -- data constructor, along with [AddAnn]. @@ -1755,38 +1597,38 @@ mergeDataCon all_xs = trailingFieldDoc | singleDoc = Nothing | otherwise = mTrailingDoc - goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] + goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } - goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs) + goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs) | (mConDoc, xs') <- pDocPrev xs - , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs' + , [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs' = do { data_con <- tyConToDataCon l' tc ; let mDoc = mTrailingDoc `mplus` mConDoc - ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) } - goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] + ; return (pure (), (data_con, RecCon (L l fields), mDoc)) } + goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] = return ( pure () - , ( cL l (getRdrName (tupleDataCon Boxed (length ts))) + , ( L l (getRdrName (tupleDataCon Boxed (length ts))) , PrefixCon ts , mTrailingDoc ) ) - goFirst ((dL->L l (TyElOpd t)):xs) - | (_, t', addAnns, xs') <- pBangTy (cL l t) xs + goFirst ((L l (TyElOpd t)):xs) + | (_, t', addAnns, xs') <- pBangTy (L l t) xs = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' goFirst (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) goFirst xs = go (pure ()) mTrailingDoc [] xs - go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] + go addAnns mLastDoc ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ] = do { data_con <- tyConToDataCon l tc ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } - go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) = - go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs - go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs) - | (_, t', addAnns', xs') <- pBangTy (cL l t) xs + go addAnns mLastDoc ts ((L l (TyElDocPrev doc)):xs) = + go addAnns (mLastDoc `mplus` Just (L l doc)) ts xs + go addAnns mLastDoc ts ((L l (TyElOpd t)):xs) + | (_, t', addAnns', xs') <- pBangTy (L l t) xs , t'' <- mkLHsDocTyMaybe t' mLastDoc = go (addAnns >> addAnns') Nothing (t'':ts) xs' - go _ _ _ ((dL->L _ (TyElOpr _)):_) = + go _ _ _ ((L _ (TyElOpr _)):_) = -- Encountered an operator: backtrack to the beginning and attempt -- to parse as an infix definition. goInfix @@ -1804,7 +1646,7 @@ mergeDataCon all_xs = ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr ; let (mOpDoc, xs2) = pDocPrev xs1 ; (op, xs3) <- case xs2 of - (dL->L l (TyElOpr op)) : xs3 -> + (L l (TyElOpr op)) : xs3 -> do { data_con <- tyConToDataCon l op ; return (data_con, xs3) } _ -> Left malformedErr @@ -1847,6 +1689,17 @@ checkMonadComp = do -- See Note [Parser-Validator] -- See Note [Ambiguous syntactic categories] +-- +-- This newtype is required to avoid impredicative types in monadic +-- productions. That is, in a production that looks like +-- +-- | ... {% return (ECP ...) } +-- +-- we are dealing with +-- P ECP +-- whereas without a newtype we would be dealing with +-- P (forall b. DisambECP b => PV (Located b)) +-- newtype ECP = ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) } @@ -1866,14 +1719,14 @@ class DisambInfixOp b where mkHsConOpPV :: Located RdrName -> PV (Located b) mkHsInfixHolePV :: SrcSpan -> PV (Located b) -instance p ~ GhcPs => DisambInfixOp (HsExpr p) where - mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v) - mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v) - mkHsInfixHolePV l = return $ cL l hsHoleExpr +instance DisambInfixOp (HsExpr GhcPs) where + mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsInfixHolePV l = return $ L l hsHoleExpr instance DisambInfixOp RdrName where - mkHsConOpPV (dL->L l v) = return $ cL l v - mkHsVarOpPV (dL->L l v) = return $ cL l v + mkHsConOpPV (L l v) = return $ L l v + mkHsVarOpPV (L l v) = return $ L l v mkHsInfixHolePV l = addFatalError l $ text "Invalid infix hole, expected an infix operator" @@ -1893,7 +1746,7 @@ class b ~ (Body b) GhcPs => DisambECP b where mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) -- | Infix operator representation type InfixOp b - -- | Bring superclass constraints on FunArg into scope. + -- | Bring superclass constraints on InfixOp into scope. -- See Note [UndecidableSuperClasses for associated types] superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) -- | Disambiguate "f # x" (infix operator) @@ -1950,11 +1803,15 @@ class b ~ (Body b) GhcPs => DisambECP b where mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) -- | Disambiguate "~a" (lazy pattern) mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) + -- | Disambiguate "!a" (bang pattern) + mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b) -- | Disambiguate tuple sections and unboxed sums mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) {- Note [UndecidableSuperClasses for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This Note is about the code in GHC, not about the user code that we are parsing) + Assume we have a class C with an associated type T: class C a where @@ -1995,37 +1852,37 @@ PatBuilder, but leads to worse type inference, breaking some code in the typechecker. -} -instance p ~ GhcPs => DisambECP (HsCmd p) where - type Body (HsCmd p) = HsCmd +instance DisambECP (HsCmd GhcPs) where + type Body (HsCmd GhcPs) = HsCmd ecpFromCmd' = return - ecpFromExp' (dL-> L l e) = cmdFail l (ppr e) - mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg) - mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e) - type InfixOp (HsCmd p) = HsExpr p + ecpFromExp' (L l e) = cmdFail l (ppr e) + mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg) + mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e) + type InfixOp (HsCmd GhcPs) = HsExpr GhcPs superInfixOp m = m mkHsOpAppPV l c1 op c2 = do - let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c - return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] - mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg) - type FunArg (HsCmd p) = HsExpr p + let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c + return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] + mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg) + type FunArg (HsCmd GhcPs) = HsExpr GhcPs superFunArg m = m mkHsAppPV l c e = do checkCmdBlockArguments c checkExpBlockArguments e - return $ cL l (HsCmdApp noExtField c e) + return $ L l (HsCmdApp noExtField c e) mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b - return $ cL l (mkHsCmdIf c a b) - mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts) - mkHsParPV l c = return $ cL l (HsCmdPar noExtField c) - mkHsVarPV (dL->L l v) = cmdFail l (ppr v) - mkHsLitPV (dL->L l a) = cmdFail l (ppr a) - mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a) + return $ L l (mkHsCmdIf c a b) + mkHsDoPV l stmts = return $ L l (HsCmdDo noExtField stmts) + mkHsParPV l c = return $ L l (HsCmdPar noExtField c) + mkHsVarPV (L l v) = cmdFail l (ppr v) + mkHsLitPV (L l a) = cmdFail l (ppr a) + mkHsOverLitPV (L l a) = cmdFail l (ppr a) mkHsWildCardPV l = cmdFail l (text "_") mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) mkHsExplicitListPV l xs = cmdFail l $ brackets (fsep (punctuate comma (map ppr xs))) - mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp) + mkHsSplicePV (L l sp) = cmdFail l (ppr sp) mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ ppr a <+> ppr (mk_rec_fields fbinds ddLoc) mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) @@ -2039,68 +1896,69 @@ instance p ~ GhcPs => DisambECP (HsCmd p) where pprPrefixOcc (unLoc v) <> text "@" <> ppr c mkHsLazyPatPV l c = cmdFail l $ text "~" <> ppr c + mkHsBangPatPV l c = cmdFail l $ + text "!" <> ppr c mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) cmdFail :: SrcSpan -> SDoc -> PV a cmdFail loc e = addFatalError loc $ hang (text "Parse error in command:") 2 (ppr e) -instance p ~ GhcPs => DisambECP (HsExpr p) where - type Body (HsExpr p) = HsExpr - ecpFromCmd' (dL -> L l c) = do +instance DisambECP (HsExpr GhcPs) where + type Body (HsExpr GhcPs) = HsExpr + ecpFromCmd' (L l c) = do addError l $ vcat [ text "Arrow command found where an expression was expected:", nest 2 (ppr c) ] - return (cL l hsHoleExpr) + return (L l hsHoleExpr) ecpFromExp' = return - mkHsLamPV l mg = return $ cL l (HsLam noExtField mg) - mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c) - type InfixOp (HsExpr p) = HsExpr p + mkHsLamPV l mg = return $ L l (HsLam noExtField mg) + mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) + type InfixOp (HsExpr GhcPs) = HsExpr GhcPs superInfixOp m = m mkHsOpAppPV l e1 op e2 = do - return $ cL l $ OpApp noExtField e1 op e2 - mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg) - type FunArg (HsExpr p) = HsExpr p + return $ L l $ OpApp noExtField e1 op e2 + mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg) + type FunArg (HsExpr GhcPs) = HsExpr GhcPs superFunArg m = m mkHsAppPV l e1 e2 = do checkExpBlockArguments e1 checkExpBlockArguments e2 - return $ cL l (HsApp noExtField e1 e2) + return $ L l (HsApp noExtField e1 e2) mkHsIfPV l c semi1 a semi2 b = do checkDoAndIfThenElse c semi1 a semi2 b - return $ cL l (mkHsIf c a b) - mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts) - mkHsParPV l e = return $ cL l (HsPar noExtField e) - mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v) - mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a) - mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a) - mkHsWildCardPV l = return $ cL l hsHoleExpr - mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) - mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs) + return $ L l (mkHsIf c a b) + mkHsDoPV l stmts = return $ L l (HsDo noExtField DoExpr stmts) + mkHsParPV l e = return $ L l (HsPar noExtField e) + mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v) + mkHsLitPV (L l a) = return $ L l (HsLit noExtField a) + mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a) + mkHsWildCardPV l = return $ L l hsHoleExpr + mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) + mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs) mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp mkHsRecordPV l lrec a (fbinds, ddLoc) = do r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) - checkRecordSyntax (cL l r) - mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr) - mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e) - mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty - mkHsAsPatPV l v e = do - opt_TypeApplications <- getBit TypeApplicationsBit - let msg | opt_TypeApplications - = "Type application syntax requires a space before '@'" - | otherwise - = "Did you mean to enable TypeApplications?" - patSynErr l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) (text msg) - mkHsLazyPatPV l e = patSynErr l (text "~" <> ppr e) empty + checkRecordSyntax (L l r) + mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr) + mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e) + mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty + mkHsAsPatPV l v e = + patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $ + text "Type application syntax requires a space before '@'" + mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $ + text "Did you mean to add a space after the '~'?" + mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $ + text "Did you mean to add a space after the '!'?" mkSumOrTuplePV = mkSumOrTupleExpr -patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs) -patSynErr l e explanation = +patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs) +patSynErr item l e explanation = do { addError l $ - sep [text "Pattern syntax in expression context:", + sep [text item <+> text "in expression context:", nest 4 (ppr e)] $$ explanation - ; return (cL l hsHoleExpr) } + ; return (L l hsHoleExpr) } hsHoleExpr :: HsExpr (GhcPass id) hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") @@ -2108,21 +1966,14 @@ hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p = PatBuilderPat (Pat p) - | PatBuilderBang SrcSpan (Located (PatBuilder p)) | PatBuilderPar (Located (PatBuilder p)) | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) | PatBuilderVar (Located RdrName) | PatBuilderOverLit (HsOverLit GhcPs) -patBuilderBang :: SrcSpan -> Located (PatBuilder p) -> Located (PatBuilder p) -patBuilderBang bang p = - cL (bang `combineSrcSpans` getLoc p) $ - PatBuilderBang bang p - instance Outputable (PatBuilder GhcPs) where ppr (PatBuilderPat p) = ppr p - ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p ppr (PatBuilderPar (L _ p)) = parens (ppr p) ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2 @@ -2131,10 +1982,10 @@ instance Outputable (PatBuilder GhcPs) where instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder - ecpFromCmd' (dL-> L l c) = + ecpFromCmd' (L l c) = addFatalError l $ text "Command syntax in pattern:" <+> ppr c - ecpFromExp' (dL-> L l e) = + ecpFromExp' (L l e) = addFatalError l $ text "Expression syntax in pattern:" <+> ppr e mkHsLamPV l _ = addFatalError l $ @@ -2143,53 +1994,54 @@ instance DisambECP (PatBuilder GhcPs) where mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern" type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m - mkHsOpAppPV l p1 op p2 = do - warnSpaceAfterBang op (getLoc p2) - return $ cL l $ PatBuilderOpApp p1 op p2 + mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2 mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern" type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m - mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2) + mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern" - mkHsParPV l p = return $ cL l (PatBuilderPar p) - mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v) - mkHsLitPV lit@(dL->L l a) = do + mkHsParPV l p = return $ L l (PatBuilderPar p) + mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v) + mkHsLitPV lit@(L l a) = do checkUnboxedStringLitPat lit - return $ cL l (PatBuilderPat (LitPat noExtField a)) - mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a) - mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField)) + return $ L l (PatBuilderPat (LitPat noExtField a)) + mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) + mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) mkHsTySigPV l b sig = do p <- checkLPat b - return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig))) + return $ L l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig))) mkHsExplicitListPV l xs = do ps <- traverse checkLPat xs - return (cL l (PatBuilderPat (ListPat noExtField ps))) - mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp)) + return (L l (PatBuilderPat (ListPat noExtField ps))) + mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) mkHsRecordPV l _ a (fbinds, ddLoc) = do r <- mkPatRec a (mk_rec_fields fbinds ddLoc) - checkRecordSyntax (cL l r) - mkHsNegAppPV l (dL->L lp p) = do + checkRecordSyntax (L l r) + mkHsNegAppPV l (L lp p) = do lit <- case p of - PatBuilderOverLit pos_lit -> return (cL lp pos_lit) + PatBuilderOverLit pos_lit -> return (L lp pos_lit) _ -> patFail l (text "-" <> ppr p) - return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) - mkHsSectionR_PV l op p - | isBangRdr (unLoc op) = return $ cL l $ PatBuilderBang (getLoc op) p - | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p) + return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) + mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p) mkHsViewPatPV l a b = do p <- checkLPat b - return $ cL l (PatBuilderPat (ViewPat noExtField a p)) + return $ L l (PatBuilderPat (ViewPat noExtField a p)) mkHsAsPatPV l v e = do p <- checkLPat e - return $ cL l (PatBuilderPat (AsPat noExtField v p)) + return $ L l (PatBuilderPat (AsPat noExtField v p)) mkHsLazyPatPV l e = do p <- checkLPat e - return $ cL l (PatBuilderPat (LazyPat noExtField p)) + return $ L l (PatBuilderPat (LazyPat noExtField p)) + mkHsBangPatPV l e = do + p <- checkLPat e + let pb = BangPat noExtField p + hintBangPat l pb + return $ L l (PatBuilderPat pb) mkSumOrTuplePV = mkSumOrTuplePat checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () -checkUnboxedStringLitPat (dL->L loc lit) = +checkUnboxedStringLitPat (L loc lit) = case lit of HsStringPrim _ _ -- Trac #13260 -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit) @@ -2206,19 +2058,6 @@ mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) mkPatRec p _ = addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p --- | Warn about missing space after bang -warnSpaceAfterBang :: Located RdrName -> SrcSpan -> PV () -warnSpaceAfterBang (dL->L opLoc op) argLoc = do - bang_on <- getBit BangPatBit - when (not bang_on && noSpace && isBangRdr op) $ - addWarning Opt_WarnSpaceAfterBang span msg - where - span = combineSrcSpans opLoc argLoc - noSpace = srcSpanEnd opLoc == srcSpanStart argLoc - msg = text "Did you forget to enable BangPatterns?" $$ - text "If you mean to bind (!) then perhaps you want" $$ - text "to add a space after the bang for clarity." - {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2243,12 +2082,12 @@ Guards: Top-level value/function declarations (FunBind/PatBind): - f !a -- TH splice - f !a = ... -- function declaration + f ! a -- TH splice + f ! a = ... -- function declaration Until we encounter the = sign, we don't know if it's a top-level - TemplateHaskell splice where ! is an infix operator, or if it's a function - declaration where ! is a strictness annotation. + TemplateHaskell splice where ! is used, or if it's a function declaration + where ! is bound. There are also places in the grammar where we do not know whether we are parsing an expression or a command: @@ -2274,9 +2113,9 @@ or an extra pass over the entire AST, is to parse into an overloaded parser-validator (a so-called tagless final encoding): class DisambECP b where ... - instance p ~ GhcPs => DisambECP (HsCmd p) where ... - instance p ~ GhcPs => DisambECP (HsExp p) where ... - instance p ~ GhcPs => DisambECP (PatBuilder p) where ... + instance DisambECP (HsCmd GhcPs) where ... + instance DisambECP (HsExp GhcPs) where ... + instance DisambECP (PatBuilder GhcPs) where ... The 'DisambECP' class contains functions to build and validate 'b'. For example, to add parentheses we have: @@ -2310,6 +2149,12 @@ Compared to the initial definition, the added bits are: The overhead is constant relative to the size of the rest of the reduction rule, so this approach scales well to large parser productions. +Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding +position and shadows the previous $1. We can do this because internally +'happy' desugars $n to happy_var_n, and the rationale behind this idiom +is to be able to write (sLL $1 $>) later on. The alternative would be to +write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer +to the last fresh name as $>. -} @@ -2337,21 +2182,6 @@ There are several issues with this: * HsExpr is arbitrarily selected as the extension basis. Why not extend HsCmd or HsPat with extra constructors instead? - * We cannot handle corner cases. For instance, the following function - declaration LHS is not a valid expression (see #1087): - - !a + !b = ... - - * There are points in the pipeline where the representation was awfully - incorrect. For instance, - - f !a b !c = ... - - is first parsed as - - (f ! a b) ! c = ... - - Alternative II, extra constructors in GHC.Hs.Expr for GhcPs ----------------------------------------------------------- We could address some of the problems with Alternative I by using Trees That @@ -2598,7 +2428,7 @@ tagless final encoding, and there's no need for this complexity. {- Note [PatBuilder] ~~~~~~~~~~~~~~~~~~~~ -Unlike HsExpr or HsCmd, the Pat type cannot accomodate all intermediate forms, +Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms, so we introduce the notion of a PatBuilder. Consider a pattern like this: @@ -2625,14 +2455,6 @@ Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for the intermediate forms. -Worse yet, some intermediate forms are not valid patterns at all. For example: - - Con !a !b c - -This is parsed as ((Con ! a) ! (b c)) with ! as an infix operator, and then -rearranged in 'splitBang'. But of course, neither (b c) nor (Con ! a) are valid -patterns, so we cannot represent them as Pat. - We also need an intermediate representation to postpone disambiguation between FunBind and PatBind. Consider: @@ -2657,12 +2479,6 @@ parsing results for patterns and function bindings: It can represent any pattern via 'PatBuilderPat', but it also has a variety of other constructors which were added by following a simple principle: we never pattern match on the pattern stored inside 'PatBuilderPat'. - -For example, in 'splitBang' we need to match on space-separated and -bang-separated patterns, so these are represented with dedicated constructors -'PatBuilderApp' and 'PatBuilderOpApp'. In 'isFunLhs', we pattern match on -variables, so we have a dedicated 'PatBuilderVar' constructor for this despite -the existence of 'VarPat'. -} --------------------------------------------------------------------------- @@ -2674,7 +2490,7 @@ checkPrecP :: Located (SourceText,Int) -- ^ precedence -> Located (OrdList (Located RdrName)) -- ^ operators -> P () -checkPrecP (dL->L l (_,i)) (dL->L _ ol) +checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure () | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) @@ -2688,9 +2504,9 @@ mkRecConstrOrUpdate -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) -> PV (HsExpr GhcPs) -mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) +mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd) | isRdrDataCon c - = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) + = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp _ (fs,dd) | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) @@ -2708,15 +2524,13 @@ mkRdrRecordCon con flds mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs - , rec_dotdot = Just (cL s (length fs)) } + , rec_dotdot = Just (L s (length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) +mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun -mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _) +mk_rec_upd_field (HsRecField (L _ (XFieldOcc nec)) _ _) = noExtCon nec -mk_rec_upd_field (HsRecField _ _ _) - = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -2759,7 +2573,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = -- name (cf section 8.5.1 in Haskell 2010 report). mkCImport = do let e = unpackFS entity - case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of + case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of Nothing -> addFatalError loc (text "Malformed entity string") Just importSpec -> returnSpec importSpec @@ -2771,7 +2585,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = then mkExtName (unLoc v) else entity funcTarget = CFunction (StaticTarget esrc entity' Nothing True) - importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc) + importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) returnSpec spec = return $ ForD noExtField $ ForeignImport { fd_i_ext = noExtField @@ -2846,11 +2660,11 @@ parseCImport cconv safety nm str sourceText = mkExport :: Located CCallConv -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs) -mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) +mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = return $ ForD noExtField $ ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty - , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) - (cL le esrc) } + , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) + (L le esrc) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -2877,15 +2691,15 @@ data ImpExpQcSpec = ImpExpQcName (Located RdrName) | ImpExpQcWildcard mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp (dL->L l specname) subs = +mkModuleImpExp (L l specname) subs = case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar noExtField (cL l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs noExtField . cL l <$> nameT - ImpExpAll -> IEThingAll noExtField . cL l <$> nameT + -> return $ IEVar noExtField (L l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs noExtField . L l <$> nameT + ImpExpAll -> IEThingAll noExtField . L l <$> nameT ImpExpList xs -> - (\newName -> IEThingWith noExtField (cL l newName) + (\newName -> IEThingWith noExtField (L l newName) NoIEWildcard (wrapped xs) []) <$> nameT ImpExpAllWith xs -> do allowed <- getBit PatternSynonymsBit @@ -2896,7 +2710,7 @@ mkModuleImpExp (dL->L l specname) subs = (findIndex isImpExpQcWildcard withs) ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith noExtField (cL l newName) pos ies []) + -> IEThingWith noExtField (L l newName) pos ies []) <$> nameT else addFatalError l (text "Illegal export form (use PatternSynonyms to enable)") @@ -2922,7 +2736,7 @@ mkModuleImpExp (dL->L l specname) subs = ieNameFromSpec (ImpExpQcType ln) = IEType ln ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - wrapped = map (onHasSrcSpan ieNameFromSpec) + wrapped = map (mapLoc ieNameFromSpec) mkTypeImpExp :: Located RdrName -- TcCls or Var name space -> P (Located RdrName) @@ -2933,8 +2747,8 @@ mkTypeImpExp name = return (fmap (`setRdrNameSpace` tcClsName) name) checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) -checkImportSpec ie@(dL->L _ specs) = - case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of +checkImportSpec ie@(L _ specs) = + case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of [] -> return ie (l:_) -> importSpecError l where @@ -2946,7 +2760,7 @@ checkImportSpec ie@(dL->L _ specs) = -- In the correct order mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] = +mkImpExpSubSpec [L _ ImpExpQcWildcard] = return ([], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) @@ -2979,7 +2793,7 @@ failOpNotEnabledImportQualifiedPost loc = addError loc msg failOpImportQualifiedTwice :: SrcSpan -> P () failOpImportQualifiedTwice loc = addError loc msg where - msg = text "Multiple occurences of 'qualified'" + msg = text "Multiple occurrences of 'qualified'" warnStarIsType :: SrcSpan -> P () warnStarIsType span = addWarning Opt_WarnStarIsType span msg @@ -3002,7 +2816,7 @@ warnStarBndr span = addWarning Opt_WarnStarBinder span msg $$ text " including the definition module, you must qualify it." failOpFewArgs :: Located RdrName -> P a -failOpFewArgs (dL->L loc op) = +failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit ; let msg = too_few $$ starInfo star_is_type op ; addFatalError loc msg } @@ -3014,18 +2828,6 @@ failOpDocPrev loc = addFatalError loc msg where msg = text "Unexpected documentation comment." -failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a -failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg - where - msg = text "Strictness annotation applied to a compound type." $$ - text "Did you mean to add parentheses?" $$ - nest 2 (ppr str <> parens (ppr ty)) - -failOpStrictnessPosition :: Located SrcStrictness -> P a -failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg - where - msg = text "Strictness annotation cannot appear in this position." - ----------------------------------------------------------------------------- -- Misc utils @@ -3191,11 +2993,11 @@ no effect on the error messages. -} -- | Hint about bang patterns, assuming @BangPatterns@ is off. -hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV () +hintBangPat :: SrcSpan -> Pat GhcPs -> PV () hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $ - addFatalError span + addError span (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) data SumOrTuple b @@ -3221,14 +3023,14 @@ mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExp -- Tuple mkSumOrTupleExpr l boxity (Tuple es) = - return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity) + return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity) where toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) -- Sum mkSumOrTupleExpr l Unboxed (Sum alt arity e) = - return $ cL l (ExplicitSum noExtField alt arity e) + return $ L l (ExplicitSum noExtField alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed a)) @@ -3238,17 +3040,17 @@ mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Loc -- Tuple mkSumOrTuplePat l boxity (Tuple ps) = do ps' <- traverse toTupPat ps - return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity)) + return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity)) where toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) - toTupPat (dL -> L l p) = case p of + toTupPat (L l p) = case p of Nothing -> addFatalError l (text "Tuple section in pattern context") Just p' -> checkLPat p' -- Sum mkSumOrTuplePat l Unboxed (Sum alt arity p) = do p' <- checkLPat p - return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity)) + return $ L l (PatBuilderPat (SumPat noExtField p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} = addFatalError l (hang (text "Boxed sums not supported:") 2 (pprSumOrTuple Boxed a)) @@ -3256,12 +3058,12 @@ mkSumOrTuplePat l Boxed a@Sum{} = mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y - in cL loc (mkHsOpTy x op y) + in L loc (mkHsOpTy x op y) mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs mkLHsDocTy t doc = let loc = getLoc t `combineSrcSpans` getLoc doc - in cL loc (HsDocTy noExtField t doc) + in L loc (HsDocTy noExtField t doc) mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 2acb2a0019..3bcc8670ff 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -2092,6 +2092,7 @@ errorIdKey = mkPreludeMiscIdUnique 5 foldrIdKey = mkPreludeMiscIdUnique 6 recSelErrorIdKey = mkPreludeMiscIdUnique 7 seqIdKey = mkPreludeMiscIdUnique 8 +absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 eqStringIdKey = mkPreludeMiscIdUnique 10 noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 @@ -2107,7 +2108,6 @@ voidPrimIdKey = mkPreludeMiscIdUnique 21 typeErrorIdKey = mkPreludeMiscIdUnique 22 divIntIdKey = mkPreludeMiscIdUnique 23 modIntIdKey = mkPreludeMiscIdUnique 24 -absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, returnIOIdKey, newStablePtrIdKey, diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index ffee79da36..c6c27f8ffe 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -191,29 +191,35 @@ primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit , subsumedByPrimOp Narrow8IntOp , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp - , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ] + , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ] primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit , subsumedByPrimOp Narrow8IntOp , subsumedByPrimOp Narrow16IntOp - , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ] + , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp + , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ] primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit , subsumedByPrimOp Narrow8IntOp , subsumedByPrimOp Narrow16IntOp , subsumedByPrimOp Narrow32IntOp - , removeOp32 ] + , removeOp32 + , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ] primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit , subsumedByPrimOp Narrow8WordOp , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp - , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ] + , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow8WordOp 8 ] primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit , subsumedByPrimOp Narrow8WordOp , subsumedByPrimOp Narrow16WordOp - , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ] + , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp + , narrowSubsumesAnd AndOp Narrow16WordOp 16 ] primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit , subsumedByPrimOp Narrow8WordOp , subsumedByPrimOp Narrow16WordOp , subsumedByPrimOp Narrow32WordOp - , removeOp32 ] + , removeOp32 + , narrowSubsumesAnd AndOp Narrow32WordOp 32 ] primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit , inversePrimOp ChrOp ] primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs @@ -649,6 +655,26 @@ subsumedByPrimOp primop = do matchPrimOpId primop primop_id return e +-- | narrow subsumes bitwise `and` with full mask (cf #16402): +-- +-- narrowN (x .&. m) +-- m .&. (2^N-1) = 2^N-1 +-- ==> narrowN x +-- +-- e.g. narrow16 (x .&. 0xFFFF) +-- ==> narrow16 x +-- +narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr +narrowSubsumesAnd and_primop narrw n = do + [Var primop_id `App` x `App` y] <- getArgs + matchPrimOpId and_primop primop_id + let mask = bit n -1 + g v (Lit (LitNumber _ m _)) = do + guard (m .&. mask == mask) + return (Var (mkPrimOpId narrw) `App` v) + g _ _ = mzero + g x y <|> g y x + idempotent :: RuleM CoreExpr idempotent = do [e1, e2] <- getArgs guard $ cheapEqExpr e1 e2 @@ -733,8 +759,8 @@ There are two cases: from the 'integer' library. These are handled by rule_shift_op, and match_Integer_shift_op. - Here we could in principle shift by any amount, but we arbitary - limit the shift to 4 bits; in particualr we do not want shift by a + Here we could in principle shift by any amount, but we arbitrary + limit the shift to 4 bits; in particular we do not want shift by a huge amount, which can happen in code like that above. The two cases are more different in their code paths that is comfortable, @@ -855,7 +881,7 @@ leftIdentityDynFlags id_lit = do return e2 -- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in --- addition to the result, we have to indicate that no carry/overflow occured. +-- addition to the result, we have to indicate that no carry/overflow occurred. leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr leftIdentityCDynFlags id_lit = do dflags <- getDynFlags @@ -872,7 +898,7 @@ rightIdentityDynFlags id_lit = do return e1 -- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in --- addition to the result, we have to indicate that no carry/overflow occured. +-- addition to the result, we have to indicate that no carry/overflow occurred. rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr rightIdentityCDynFlags id_lit = do dflags <- getDynFlags @@ -886,7 +912,7 @@ identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit -- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition --- to the result, we have to indicate that no carry/overflow occured. +-- to the result, we have to indicate that no carry/overflow occurred. identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr identityCDynFlags lit = leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 79a30482b0..a023c430fe 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -239,7 +239,7 @@ tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPr stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon -bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon +bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon @@ -1052,10 +1052,13 @@ compactPrimTy = mkTyConTy compactPrimTyCon ************************************************************************ -} +-- Unlike most other primitive types, BCO is lifted. This is because in +-- general a BCO may be a thunk for the reasons given in Note [Updatable CAF +-- BCOs] in GHCi.CreateBCO. bcoPrimTy :: Type bcoPrimTy = mkTyConTy bcoPrimTyCon bcoPrimTyCon :: TyCon -bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName LiftedRep {- ************************************************************************ diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index b1ba7bf4b2..de7ec7ec81 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -260,6 +260,27 @@ eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConK eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId +{- Note [eqTyCon (~) is built-in syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The (~) type operator used in equality constraints (a~b) is considered built-in +syntax. This has a few consequences: + +* The user is not allowed to define their own type constructors with this name: + + ghci> class a ~ b + <interactive>:1:1: error: Illegal binding of built-in syntax: ~ + +* Writing (a ~ b) does not require enabling -XTypeOperators. It does, however, + require -XGADTs or -XTypeFamilies. + +* The (~) type operator is always in scope. It doesn't need to be be imported, + and it cannot be hidden. + +* We have a bunch of special cases in the compiler to arrange all of the above. + +There's no particular reason for (~) to be special, but fixing this would be a +breaking change. +-} eqTyCon_RDR :: RdrName eqTyCon_RDR = nameRdrName eqTyConName diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index f47880b58d..de7d498da1 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -251,6 +251,13 @@ primop IntMulOp "*#" with commutable = True fixity = infixl 7 +primop IntMul2Op "timesInt2#" GenPrimOp + Int# -> Int# -> (# Int#, Int#, Int# #) + {Return a triple (isHighNeeded,high,low) where high and low are respectively + the high and low bits of the double-word result. isHighNeeded is a cheap way + to test if the high word is a sign-extension of the low word (isHighNeeded = + 0#) or not (isHighNeeded = 1#).} + primop IntMulMayOfloOp "mulIntMayOflo#" Dyadic Int# -> Int# -> Int# {Return non-zero if there is any possibility that the upper word of a @@ -2057,7 +2064,7 @@ primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) {Given an array, and offset in machine words, and a value to subtract, - atomically substract the value to the element. Returns the value of + atomically subtract the value to the element. Returns the value of the element before the operation. Implies a full memory barrier.} with has_side_effects = True can_fail = True @@ -3242,7 +3249,7 @@ section "Bytecode operations" contain a list of instructions and data needed by these instructions.} ------------------------------------------------------------------------ -primtype BCO# +primtype BCO { Primitive bytecode type. } primop AddrToAnyOp "addrToAny#" GenPrimOp @@ -3267,14 +3274,14 @@ primop AnyToAddrOp "anyToAddr#" GenPrimOp code_size = 0 primop MkApUpd0_Op "mkApUpd0#" GenPrimOp - BCO# -> (# a #) + BCO -> (# a #) { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of the BCO when evaluated. } with out_of_line = True primop NewBCOOp "newBCO#" GenPrimOp - ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO# #) + ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) { {\tt newBCO\# instrs lits ptrs arity bitmap} creates a new bytecode object. The resulting object encodes a function of the given arity with the instructions encoded in {\tt instrs}, and a static reference table usage bitmap given by diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index c84e7bd328..00a76df77a 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -1137,7 +1137,7 @@ constructor namespace before looking in the data constructor namespace to deal with `DataKinds`. There is however, as always, one exception to this scheme. If we find -an ambiguous occurence of a record selector and DuplicateRecordFields +an ambiguous occurrence of a record selector and DuplicateRecordFields is enabled then we defer the selection until the typechecker. -} @@ -1555,7 +1555,13 @@ dataTcOccs rdr_name = [rdr_name] where occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName + rdr_name_tc = + case rdr_name of + -- The (~) type operator is always in scope, so we need a special case + -- for it here, or else :info (~) fails in GHCi. + -- See Note [eqTyCon (~) is built-in syntax] + Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR + _ -> setRdrNameSpace rdr_name tcName {- Note [dataTcOccs and Exact Names] diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index d3f72fff47..693d818f67 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -232,16 +232,15 @@ rnExpr expr@(SectionR {}) = do { addErr (sectionErr expr); rnSection expr } --------------------------------------------- -rnExpr (HsCoreAnn x src ann expr) +rnExpr (HsPragE x prag expr) = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsCoreAnn x src ann expr', fvs_expr) } - -rnExpr (HsSCC x src lbl expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsSCC x src lbl expr', fvs_expr) } -rnExpr (HsTickPragma x src info srcInfo expr) - = do { (expr', fvs_expr) <- rnLExpr expr - ; return (HsTickPragma x src info srcInfo expr', fvs_expr) } + ; return (HsPragE x (rn_prag prag) expr', fvs_expr) } + where + rn_prag :: HsPragE GhcPs -> HsPragE GhcRn + rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann + rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl + rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo + rn_prag (XHsPragE x) = noExtCon x rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches @@ -1369,7 +1368,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later where (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later new_stmt | non_rec = head ss - | otherwise = cL (getLoc (head ss)) rec_stmt + | otherwise = L (getLoc (head ss)) rec_stmt rec_stmt = empty_rec_stmt { recS_stmts = ss , recS_later_ids = nameSetElemsStable used_later , recS_rec_ids = nameSetElemsStable fwds } diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs index deaedb8bca..6af59a0210 100644 --- a/compiler/rename/RnHsDoc.hs +++ b/compiler/rename/RnHsDoc.hs @@ -17,9 +17,9 @@ rnMbLHsDoc mb_doc = case mb_doc of Nothing -> return Nothing rnLHsDoc :: LHsDocString -> RnM LHsDocString -rnLHsDoc (dL->L pos doc) = do +rnLHsDoc (L pos doc) = do doc' <- rnHsDoc doc - return (cL pos doc') + return (L pos doc') rnHsDoc :: HsDocString -> RnM HsDocString rnHsDoc = pure diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 8d1083a547..7614fb1932 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -92,7 +92,7 @@ mode changes, this triggers a recompilation from that module in the dependcy graph. So we can just worry mostly about direct imports. There is one trust property that can change for a package though without -recompliation being triggered: package trust. So we must check that all +recompilation being triggered: package trust. So we must check that all packages a module tranitively depends on to be trusted are still trusted when we are compiling this module (as due to recompilation avoidance some modules below may not be considered trusted any more without recompilation being diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 61cdc140bf..59ab5446cd 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -129,13 +129,12 @@ liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing ; (r,fvs2) <- k v ; return (r, fvs1 `plusFV` fvs2) }) -wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b +wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) -- Set the location, and also wrap it around the value returned -wrapSrcSpanCps fn (dL->L loc a) +wrapSrcSpanCps fn (L loc a) = CpsRn (\k -> setSrcSpan loc $ unCpsRn (fn a) $ \v -> - k (cL loc v)) + k (L loc v)) lookupConCps :: Located RdrName -> CpsRn (Located Name) lookupConCps con_rdr @@ -220,9 +219,9 @@ rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) -newPatLName name_maker rdr_name@(dL->L loc _) +newPatLName name_maker rdr_name@(L loc _) = do { name <- newPatName name_maker rdr_name - ; return (cL loc name) } + ; return (L loc name) } newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name @@ -391,10 +390,10 @@ rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (LazyPat x pat') } rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (BangPat x pat') } -rnPatAndThen mk (VarPat x (dL->L l rdr)) +rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (cL loc rdr) - ; return (VarPat x (cL l name)) } + ; name <- newPatName mk (L loc rdr) + ; return (VarPat x (L l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) @@ -424,7 +423,7 @@ rnPatAndThen mk (LitPat x lit) where normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } -rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq) +rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit ; mb_neg' -- See Note [Negative zero] <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName @@ -436,9 +435,9 @@ rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq) (Nothing, Nothing) -> positive (Just _ , Just _ ) -> positive ; eq' <- liftCpsFV $ lookupSyntaxName eqName - ; return (NPat x (cL l lit') mb_neg' eq') } + ; return (NPat x (L l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) +rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) = do { new_name <- newPatName mk rdr ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as @@ -446,8 +445,8 @@ rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ ) -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntaxName minusName ; ge <- liftCpsFV $ lookupSyntaxName geName - ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name) - (cL l lit') lit' ge minus) } + ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat x rdr pat) @@ -540,7 +539,7 @@ rnHsRecPatsAndThen :: NameMaker -> Located Name -- Constructor -> HsRecFields GhcPs (LPat GhcPs) -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) -rnHsRecPatsAndThen mk (dL->L _ con) +rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields @@ -548,10 +547,10 @@ rnHsRecPatsAndThen mk (dL->L _ con) ; check_unused_wildcard (implicit_binders flds' <$> dd) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - mkVarPat l n = VarPat noExtField (cL l n) - rn_field (dL->L l fld, n') = + mkVarPat l n = VarPat noExtField (L l n) + rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldArg = arg' })) } + ; return (L l (fld { hsRecFieldArg = arg' })) } loc = maybe noSrcSpan getLoc dd @@ -585,12 +584,12 @@ data HsRecFieldContext | HsRecFieldUpd rnHsRecFields - :: forall arg. HasSrcSpan arg => + :: forall arg. HsRecFieldContext - -> (SrcSpan -> RdrName -> SrcSpanLess arg) + -> (SrcSpan -> RdrName -> arg) -- When punning, use this to build a new field - -> HsRecFields GhcPs arg - -> RnM ([LHsRecField GhcRn arg], FreeVars) + -> HsRecFields GhcPs (Located arg) + -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -616,38 +615,36 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) HsRecFieldPat con -> Just con _ {- update -} -> Nothing - rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg - -> RnM (LHsRecField GhcRn arg) - rn_fld pun_ok parent (dL->L l + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) + -> RnM (LHsRecField GhcRn (Located arg)) + rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = - (dL->L loc (FieldOcc _ (dL->L ll lbl))) + (L loc (FieldOcc _ (L ll lbl))) , hsRecFieldArg = arg , hsRecPun = pun })) = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (cL loc lbl)) + then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (cL loc (mk_arg loc arg_rdr)) } + ; return (L loc (mk_arg loc arg_rdr)) } else return arg - ; return (cL l (HsRecField - { hsRecFieldLbl = (cL loc (FieldOcc - sel (cL ll lbl))) + ; return (L l (HsRecField + { hsRecFieldLbl = (L loc (FieldOcc + sel (L ll lbl))) , hsRecFieldArg = arg' , hsRecPun = pun })) } - rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) + rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) = panic "rnHsRecFields" - rn_fld _ _ _ = panic "rn_fld: Impossible Match" - -- due to #15884 rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) - -> [LHsRecField GhcRn arg] -- Explicit fields - -> RnM ([LHsRecField GhcRn arg]) -- Field Labels we need to fill in - rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match + -> [LHsRecField GhcRn (Located arg)] -- Explicit fields + -> RnM ([LHsRecField GhcRn (Located arg)]) -- Field Labels we need to fill in + rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add -- an error but still return an unbound name. We @@ -679,9 +676,9 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) _other -> True ] ; addUsedGREs dot_dot_gres - ; return [ cL loc (HsRecField - { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr)) - , hsRecFieldArg = cL loc (mk_arg loc arg_rdr) + ; return [ L loc (HsRecField + { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) + , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl @@ -726,9 +723,9 @@ rnHsRecUpdFields flds rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f - , hsRecFieldArg = arg - , hsRecPun = pun })) + rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f + , hsRecFieldArg = arg + , hsRecPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f ; sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker @@ -744,10 +741,10 @@ rnHsRecUpdFields flds Just r -> return r } else fmap Left $ lookupGlobalOccRn lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (cL loc lbl)) + then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (cL loc (HsVar noExtField (cL loc arg_rdr))) } + ; return (L loc (HsVar noExtField (L loc arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -757,14 +754,14 @@ rnHsRecUpdFields flds Right _ -> fvs lbl' = case sel of Left sel_name -> - cL loc (Unambiguous sel_name (cL loc lbl)) + L loc (Unambiguous sel_name (L loc lbl)) Right [sel_name] -> - cL loc (Unambiguous sel_name (cL loc lbl)) - Right _ -> cL loc (Ambiguous noExtField (cL loc lbl)) + L loc (Unambiguous sel_name (L loc lbl)) + Right _ -> L loc (Ambiguous noExtField (L loc lbl)) - ; return (cL l (HsRecField { hsRecFieldLbl = lbl' - , hsRecFieldArg = arg'' - , hsRecPun = pun }), fvs') } + ; return (L l (HsRecField { hsRecFieldLbl = lbl' + , hsRecFieldArg = arg'' + , hsRecPun = pun }), fvs') } dup_flds :: [NE.NonEmpty RdrName] -- Each list represents a RdrName that occurred more than once diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 791b6a4ceb..a166a65bfb 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -284,7 +284,7 @@ rnSrcWarnDecls _ [] rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates - ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups in addErrAt loc (dupWarnDecl lrdr' rdr)) warn_rdr_dups ; pairs_s <- mapM (addLocM rn_deprec) decls @@ -304,7 +304,7 @@ rnSrcWarnDecls bndr_set decls' what = text "deprecation" warn_rdr_dups = findDupRdrNames - $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls + $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -477,9 +477,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonadInstances | cls == applicativeClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == pureAName, isAliasMG mg == Just returnMName -> addWarnNonCanonicalMethod1 @@ -492,9 +492,9 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monadClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == returnMName, isAliasMG mg /= Just pureAName -> addWarnNonCanonicalMethod2 @@ -523,9 +523,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonoidInstances | cls == semigroupClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == sappendName, isAliasMG mg == Just mappendName -> addWarnNonCanonicalMethod1 @@ -534,9 +534,9 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monoidClassName = do - forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do case mbind of - FunBind { fun_id = (dL->L _ name) + FunBind { fun_id = L _ name , fun_matches = mg } | name == mappendName, isAliasMG mg /= Just sappendName -> addWarnNonCanonicalMethod2NoDefault @@ -549,10 +549,9 @@ checkCanonicalInstances cls poly_ty mbinds = do -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" -- binding, and return @Just rhsName@ if this is the case isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name - isAliasMG MG {mg_alts = (dL->L _ - [dL->L _ (Match { m_pats = [] + isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] , m_grhss = grhss })])} - | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss + | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss , EmptyLocalBinds _ <- unLoc lbinds , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing @@ -612,7 +611,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; cls <- case hsTyGetAppHead_maybe head_ty' of - Just (dL->L _ cls) -> pure cls + Just (L _ cls) -> pure cls Nothing -> do -- The instance is malformed. We'd still like -- to make *some* progress (rather than failing outright), so @@ -686,7 +685,7 @@ rnFamInstEqn doc atfi rhs_kvars ; tycon' <- lookupFamInstName mb_cls tycon ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats -- Use the "...Dups" form because it's needed - -- below to report unsed binder on the LHS + -- below to report unused binder on the LHS -- Implicitly bound variables, empty if we have an explicit 'forall' according -- to the "forall-or-nothing" rule. @@ -794,7 +793,7 @@ rnTyFamInstEqn atfi ctf_info , feqn_rhs = rhs }}) = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs ; (eqn'@(HsIB { hsib_body = - FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs) + FamEqn { feqn_tycon = L _ tycon' }}), fvs) <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn ; case ctf_info of NotClosedTyFam -> pure () @@ -1041,15 +1040,15 @@ bindRuleTmVars doc tyvs vars names thing_inside = go vars names $ \ vars' -> bindLocalNamesFV names (thing_inside vars') where - go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside + go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside = go vars ns $ \ vars' -> - thing_inside (cL l (RuleBndr noExtField (cL loc n)) : vars') + thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') - go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars) + go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) (n : ns) thing_inside = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' -> - thing_inside (cL l (RuleBndrSig noExtField (cL loc n) bsig') : vars') + thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) @@ -1232,7 +1231,7 @@ Why do the instance declarations participate? At least two reasons the type synonym S. While we know that S depends upon 'Q depends upon Closed, we have no idea that Closed depends upon Open! - To accomodate for these situations, we ensure that an instance is checked + To accommodate for these situations, we ensure that an instance is checked before every @TyClDecl@ on which it does not depend. That's to say, instances are checked as early as possible in @tcTyAndClassDecls@. @@ -1474,12 +1473,12 @@ dupRoleAnnotErr list 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_annot list - ((dL->L loc first_decl) :| _) = sorted_list + ((L loc first_decl) :| _) = sorted_list - pp_role_annot (dL->L loc decl) = hang (ppr decl) + pp_role_annot (L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 + cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list @@ -1489,12 +1488,12 @@ dupKindSig_Err list 2 (vcat $ map pp_kisig $ NE.toList sorted_list) where sorted_list = NE.sortBy cmp_loc list - ((dL->L loc first_decl) :| _) = sorted_list + ((L loc first_decl) :| _) = sorted_list - pp_kisig (dL->L loc decl) = + pp_kisig (L loc decl) = hang (ppr decl) 4 (text "-- written at" <+> ppr loc) - cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2 + cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2 {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1640,7 +1639,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). ; let sig_rdr_names_w_locs = - [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs + [op | L _ (ClassOpSig _ False ops _) <- sigs , op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only @@ -1750,15 +1749,15 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType } where h98_style = case condecls of -- Note [Stupid theta] - (dL->L _ (ConDeclGADT {})) : _ -> False - _ -> True + (L _ (ConDeclGADT {})) : _ -> False + _ -> True - rn_derivs (dL->L loc ds) + rn_derivs (L loc ds) = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds - ; return (cL loc ds', fvs) } + ; return (L loc ds', fvs) } rnDataDefn _ (XHsDataDefn nec) = noExtCon nec warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) @@ -1787,21 +1786,19 @@ warnNoDerivStrat mds loc rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause doc - (dL->L loc (HsDerivingClause + (L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs - , deriv_clause_tys = (dL->L loc' dct) })) + , deriv_clause_tys = L loc' dct })) = do { (dcs', dct', fvs) <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct ; warnNoDerivStrat dcs' loc - ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField - , deriv_clause_strategy = dcs' - , deriv_clause_tys = cL loc' dct' }) + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs' + , deriv_clause_tys = L loc' dct' }) , fvs ) } -rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause nec)) +rnLHsDerivingClause _ (L _ (XHsDerivingClause nec)) = noExtCon nec -rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match" - -- due to #15884 rnLDerivStrategy :: forall a. HsDocContext @@ -1811,10 +1808,10 @@ rnLDerivStrategy :: forall a. rnLDerivStrategy doc mds thing_inside = case mds of Nothing -> boring_case Nothing - Just (dL->L loc ds) -> + Just (L loc ds) -> setSrcSpan loc $ do (ds', thing, fvs) <- rn_deriv_strat ds - pure (Just (cL loc ds'), thing, fvs) + pure (Just (L loc ds'), thing, fvs) where rn_deriv_strat :: DerivStrategy GhcPs -> RnM (DerivStrategy GhcRn, a, FreeVars) @@ -1902,7 +1899,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars ---------------------- rn_info :: Located Name -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) - rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns)) + rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns)) = do { (eqns', fvs) <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) -- no class context @@ -1985,17 +1982,17 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in -> LFamilyResultSig GhcRn -- ^ Result signature -> LInjectivityAnn GhcPs -- ^ Injectivity annotation -> RnM (LInjectivityAnn GhcRn) -rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) - (dL->L srcSpan (InjectivityAnn injFrom injTo)) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) + (L srcSpan (InjectivityAnn injFrom injTo)) = do - { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) <- askNoErrs $ bindLocalNames [hsLTyVarName resTv] $ -- The return type variable scopes over the injectivity annotation -- e.g. type family F a = (r::*) | r -> a do { injFrom' <- rnLTyVar injFrom ; injTo' <- mapM rnLTyVar injTo - ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') } + ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv @@ -2031,12 +2028,12 @@ rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv)) -- -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) = +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = setSrcSpan srcSpan $ do (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo - return $ cL srcSpan (InjectivityAnn injFrom' injTo') + return $ L srcSpan (InjectivityAnn injFrom' injTo') return $ injDecl' {- @@ -2102,7 +2099,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs all_fvs) }} rnConDecl decl@(ConDeclGADT { con_names = names - , con_forall = (dL->L _ explicit_forall) + , con_forall = L _ explicit_forall , con_qvars = qtvs , con_mb_cxt = mcxt , con_args = args @@ -2178,12 +2175,12 @@ rnConDeclDetails _ doc (InfixCon ty1 ty2) ; (new_ty2, fvs2) <- rnLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } -rnConDeclDetails con doc (RecCon (dL->L l fields)) +rnConDeclDetails con doc (RecCon (L l fields)) = do { fls <- lookupConstructorFields con ; (new_fields, fvs) <- rnConDeclFields doc fls fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon (cL l new_fields), fvs) } + ; return (RecCon (L l new_fields), fvs) } ------------------------------------------------- @@ -2210,20 +2207,19 @@ extendPatSynEnv val_decls local_fix_env thing = do { -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])] new_ps' bind names - | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n) - , psb_args = RecCon as }))) <- bind + | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as }))) <- bind = do - bnd_name <- newTopSrcBinder (cL bind_loc n) + bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs - mkFieldOcc (dL->L l name) = cL l (FieldOcc noExtField (cL l name)) + mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names) - | (dL->L bind_loc (PatSynBind _ - (PSB { psb_id = (dL->L _ n)}))) <- bind + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do - bnd_name <- newTopSrcBinder (cL bind_loc n) + bnd_name <- newTopSrcBinder (L bind_loc n) return ((bnd_name, []): names) | otherwise = return names @@ -2249,9 +2245,9 @@ rnHsTyVars :: [Located RdrName] -> RnM [Located Name] rnHsTyVars tvs = mapM rnHsTyVar tvs rnHsTyVar :: Located RdrName -> RnM (Located Name) -rnHsTyVar (dL->L l tyvar) = do +rnHsTyVar (L l tyvar) = do tyvar' <- lookupOccRn tyvar - return (cL l tyvar') + return (L l tyvar') {- ********************************************************* @@ -2274,7 +2270,7 @@ addl :: HsGroup GhcPs -> [LHsDecl GhcPs] -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- This stuff reverses the declarations (again) but it doesn't matter addl gp [] = return (gp, Nothing) -addl gp ((dL->L l d) : ds) = add gp l d ds +addl gp (L l d : ds) = add gp l d ds add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] @@ -2282,7 +2278,7 @@ add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] -- #10047: Declaration QuasiQuoters are expanded immediately, without -- causing a group split -add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds = do { (ds', _) <- rnTopSpliceDecls qq ; addl gp (ds' ++ ds) } @@ -2308,52 +2304,52 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds | isClassDecl d - = let fsigs = [ cL l f - | (dL->L l (FixSig _ f)) <- tcdSigs d ] in - addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds + = let fsigs = [ L l f + | L l (FixSig _ f) <- tcdSigs d ] in + addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds | otherwise - = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds -- Signatures: fixity sigs go a different place than all others add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds - = addl (gp {hs_fixds = cL l f : ts}) ds + = addl (gp {hs_fixds = L l f : ts}) ds -- Standalone kind signatures: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds - = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds + = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds - = addl (gp {hs_valds = add_sig (cL l d) ts}) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds -- Value declarations: use add_bind add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds - = addl (gp { hs_valds = add_bind (cL l d) ts }) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds -- Role annotations: added to the TyClGroup add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds - = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds -- NB instance declarations go into TyClGroups. We throw them into the first -- group, just as we do for the TyClD case. The renamer will go on to group -- and order them later. add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds - = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds + = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds -- The rest are routine add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds - = addl (gp { hs_derivds = cL l d : ts }) ds + = addl (gp { hs_derivds = L l d : ts }) ds add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds - = addl (gp { hs_defds = cL l d : ts }) ds + = addl (gp { hs_defds = L l d : ts }) ds add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds - = addl (gp { hs_fords = cL l d : ts }) ds + = addl (gp { hs_fords = L l d : ts }) ds add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds - = addl (gp { hs_warnds = cL l d : ts }) ds + = addl (gp { hs_warnds = L l d : ts }) ds add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds - = addl (gp { hs_annds = cL l d : ts }) ds + = addl (gp { hs_annds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds - = addl (gp { hs_ruleds = cL l d : ts }) ds + = addl (gp { hs_ruleds = L l d : ts }) ds add gp l (DocD _ d) ds - = addl (gp { hs_docs = (cL l d) : (hs_docs gp) }) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec add (XHsGroup nec) _ _ _ = noExtCon nec diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 3e6d64751d..6319a8ce10 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -361,13 +361,13 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote - = cL q_span $ HsApp noExtField (cL q_span - $ HsApp noExtField (cL q_span (HsVar noExtField (cL q_span quote_selector))) - quoterExpr) - quoteExpr + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector))) + quoterExpr) + quoteExpr where - quoterExpr = cL q_span $! HsVar noExtField $! (cL q_span quoter) - quoteExpr = cL q_span $! HsLit noExtField $! HsString NoSourceText quote + quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter) + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -379,19 +379,19 @@ rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice (HsTypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (cL loc splice_name) + ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsTypedSplice x hasParen n' expr', fvs) } rnSplice (HsUntypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (cL loc splice_name) + ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsUntypedSplice x hasParen n' expr', fvs) } rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) = do { loc <- getSrcSpanM - ; splice_name' <- newLocalBndrRn (cL loc splice_name) + ; splice_name' <- newLocalBndrRn (L loc splice_name) -- Rename the quoter; akin to the HsVar case of rnExpr ; quoter' <- lookupOccRn quoter @@ -620,7 +620,7 @@ rnSplicePat splice -- See Note [Delaying modFinalizers in untyped splices]. ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedPat) `onHasSrcSpan` + . HsSplicedPat) `mapLoc` pat , emptyFVs ) } @@ -629,12 +629,12 @@ rnSplicePat splice ---------------------- rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg) +rnSpliceDecl (SpliceDecl _ (L loc splice) flg) = rnSpliceGen run_decl_splice pend_decl_splice splice where pend_decl_splice rn_splice = ( makePending UntypedDeclSplice rn_splice - , SpliceDecl noExtField (cL loc rn_splice) flg) + , SpliceDecl noExtField (L loc rn_splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) rnSpliceDecl (XSpliceDecl nec) = noExtCon nec @@ -739,8 +739,8 @@ traceSplice :: SpliceInfo -> TcM () traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , spliceGenerated = gen, spliceIsDecl = is_decl }) = do { loc <- case mb_src of - Nothing -> getSrcSpanM - Just (dL->L loc _) -> return loc + Nothing -> getSrcSpanM + Just (L loc _) -> return loc ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) ; when is_decl $ -- Raw material for -dth-dec-file @@ -753,7 +753,7 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src spliceDebugDoc loc = let code = case mb_src of Nothing -> ending - Just e -> nest 2 (ppr e) : ending + Just e -> nest 2 (ppr (stripParensHsExpr e)) : ending ending = [ text "======>", nest 2 gen ] in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) 2 (sep code) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 434ed496f1..724dea866d 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -164,10 +164,10 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_lty env hs_ty ; return (nwcs, hs_ty', fvs) } where - rn_lty env (dL->L loc hs_ty) + rn_lty env (L loc hs_ty) = setSrcSpan loc $ do { (hs_ty', fvs) <- rn_ty env hs_ty - ; return (cL loc hs_ty', fvs) } + ; return (L loc hs_ty', fvs) } rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear @@ -179,23 +179,23 @@ rnWcBody ctxt nwc_rdrs hs_ty , hst_bndrs = tvs', hst_body = hs_body' } , fvs) } - rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt + rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt , hst_body = hs_ty }) | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt - , (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last + , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 - ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExtField)] + ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' } + , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } | otherwise = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField - , hst_ctxt = cL cx hs_ctxt' + , hst_ctxt = L cx hs_ctxt' , hst_body = hs_ty' } , fvs1 `plusFV` fvs2) } @@ -336,7 +336,7 @@ rnImplicitBndrs bind_free_tvs vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] ; loc <- getSrcSpanM - ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs + ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs ; bindLocalNamesFV vars $ thing_inside vars } @@ -467,11 +467,11 @@ rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args -------------- rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) -rnTyKiContext env (dL->L loc cxt) +rnTyKiContext env (L loc cxt) = do { traceRn "rncontext" (ppr cxt) ; let env' = env { rtke_what = RnConstraint } ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt - ; return (cL loc cxt', fvs) } + ; return (L loc cxt', fvs) } rnContext :: HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) @@ -479,10 +479,10 @@ rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta -------------- rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnLHsTyKi env (dL->L loc ty) +rnLHsTyKi env (L loc ty) = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi env ty - ; return (cL loc ty', fvs) } + ; return (L loc ty', fvs) } rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) @@ -504,7 +504,7 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) , hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name)) +rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ unlessXOptM LangExt.PolyKinds $ addErr $ withHsDocContext (rtke_ctxt env) $ @@ -513,7 +513,7 @@ rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name)) -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name - ; return (HsTyVar noExtField ip (cL loc name), unitFV name) } + ; return (HsTyVar noExtField ip (L loc name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) = setSrcSpan (getLoc l_op) $ @@ -660,20 +660,20 @@ rnTyVar env rdr_name rnLTyVar :: Located RdrName -> RnM (Located Name) -- Called externally; does not deal with wildards -rnLTyVar (dL->L loc rdr_name) +rnLTyVar (L loc rdr_name) = do { tyvar <- lookupTypeOccRn rdr_name - ; return (cL loc tyvar) } + ; return (L loc tyvar) } -------------- rnHsTyOp :: Outputable a => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars) -rnHsTyOp env overall_ty (dL->L loc op) +rnHsTyOp env overall_ty (L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op ; unless (ops_ok || op' `hasKey` eqTyConKey) $ addErr (opTyErr op overall_ty) - ; let l_op' = cL loc op' + ; let l_op' = L loc op' ; return (l_op', unitFV op') } -------------- @@ -989,35 +989,33 @@ bindLHsTyVarBndr :: HsDocContext -> LHsTyVarBndr GhcPs -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -bindLHsTyVarBndr _doc mb_assoc (dL->L loc +bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x - lrdr@(dL->L lv _))) thing_inside + lrdr@(L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $ - thing_inside (cL loc (UserTyVar x (cL lv nm))) } + thing_inside (L loc (UserTyVar x (L lv nm))) } -bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind)) +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr ; (b, fvs2) <- bindLocalNamesFV [tv_nm] - $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind')) + $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } -bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec -bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match" - -- due to #15884 +bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name -newTyVarNameRn mb_assoc (dL->L loc rdr) +newTyVarNameRn mb_assoc (L loc rdr) = do { rdr_env <- getLocalRdrEnv ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of (Just _, Just n) -> return n -- Use the same Name as the parent class decl - _ -> newLocalBndrRn (cL loc rdr) } + _ -> newLocalBndrRn (L loc rdr) } {- ********************************************************* * * @@ -1044,23 +1042,21 @@ rnConDeclFields ctxt fls fields rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars) -rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc)) +rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc) + ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc) , fvs) } where lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn - lookupField (FieldOcc _ (dL->L lr rdr)) = - FieldOcc (flSelector fl) (cL lr rdr) + lookupField (FieldOcc _ (L lr rdr)) = + FieldOcc (flSelector fl) (L lr rdr) where lbl = occNameFS $ rdrNameOcc rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl lookupField (XFieldOcc nec) = noExtCon nec -rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec -rnField _ _ _ = panic "rnField: Impossible Match" - -- due to #15884 +rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec {- ************************************************************************ @@ -1094,13 +1090,13 @@ mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 (\t1 t2 -> HsOpTy noExtField t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 @@ -1116,8 +1112,8 @@ mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) mk_hs_op_ty mk1 op1 fix1 ty1 mk2 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) - ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) } - | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 ; return (mk2 (noLoc new_ty) ty22) } @@ -1133,35 +1129,35 @@ mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 +mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn e12 op2 fix2 e2 - return (OpApp fix1 e11 op1 (cL loc' new_e)) + return (OpApp fix1 e11 op1 (L loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 +mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) return (OpApp fix2 e1 op2 e2) | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp noExtField (cL loc' new_e) neg_name) + return (NegApp noExtField (L loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) return (OpApp fix1 e1 op1 e2) @@ -1194,10 +1190,10 @@ instance Outputable OpName where get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar -get_op (dL->L _ (HsVar _ n)) = NormalOp (unLoc n) -get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv -get_op (dL->L _ (HsRecFld _ fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) +get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv +get_op (L _ (HsRecFld _ fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -1229,9 +1225,9 @@ mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(dL->L loc +mkOpFormRn a1@(L loc (HsCmdTop _ - (dL->L _ (HsCmdArrForm x op1 f (Just fix1) + (L _ (HsCmdArrForm x op1 f (Just fix1) [a11,a12])))) op2 fix2 a2 | nofix_error @@ -1241,7 +1237,7 @@ mkOpFormRn a1@(dL->L loc | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm noExtField op1 f (Just fix1) - [a11, cL loc (HsCmdTop [] (cL loc new_c))]) + [a11, L loc (HsCmdTop [] (L loc new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1255,7 +1251,7 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn) -mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 +mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 = do { fix1 <- lookupFixityRn (unLoc op1) ; let (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1266,7 +1262,7 @@ mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2 else if associate_right then do { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) } + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? else return (ConPatIn op2 (InfixCon p1 p2)) } @@ -1284,12 +1280,12 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch op (MG { mg_alts = (dL->L _ ms) }) +checkPrecMatch op (MG { mg_alts = (L _ ms) }) = mapM_ check ms where - check (dL->L _ (Match { m_pats = (dL->L l1 p1) - : (dL->L l2 p2) - : _ })) + check (L _ (Match { m_pats = (L l1 p1) + : (L l2 p2) + : _ })) = setSrcSpan (combineSrcSpans l1 l2) $ do checkPrec op p1 False checkPrec op p2 True @@ -1398,7 +1394,7 @@ unexpectedTypeSigErr ty 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () -badKindSigErr doc (dL->L loc ty) +badKindSigErr doc (L loc ty) = setSrcSpan loc $ addErr $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) @@ -1416,7 +1412,7 @@ inTypeDoc :: HsType GhcPs -> SDoc inTypeDoc ty = text "In the type" <+> quotes (ppr ty) warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () -warnUnusedForAll in_doc (dL->L loc tv) used_names +warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ addWarnAt (Reason Opt_WarnUnusedForalls) loc $ @@ -1653,7 +1649,7 @@ extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups extractHsTysRdrTyVarsDups tys = extract_ltys tys [] --- Returns the free kind variables of any explictly-kinded binders, returning +-- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. -- NB: Does /not/ delete the binders themselves. @@ -1668,9 +1664,9 @@ extractHsTyVarBndrsKVs tv_bndrs -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] -extractRdrKindSigVars (dL->L _ resultSig) - | KindSig _ k <- resultSig = extractHsTyRdrTyVars k - | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k +extractRdrKindSigVars (L _ resultSig) + | KindSig _ k <- resultSig = extractHsTyRdrTyVars k + | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k | otherwise = [] -- Get type/kind variables mentioned in the kind signature, preserving @@ -1695,7 +1691,7 @@ extract_ltys tys acc = foldr extract_lty acc tys extract_lty :: LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups -extract_lty (dL->L _ ty) acc +extract_lty (L _ ty) acc = case ty of HsTyVar _ _ ltv -> extract_tv ltv acc HsBangTy _ _ ty -> extract_lty ty acc @@ -1758,7 +1754,7 @@ extract_hs_tv_bndrs tv_bndrs acc_vars body_vars tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] --- Returns the free kind variables of any explictly-kinded binders, returning +-- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. -- NB: Does /not/ delete the binders themselves. @@ -1767,7 +1763,7 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] -- the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs = foldr extract_lty [] - [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs] + [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] extract_tv :: Located RdrName -> [Located RdrName] -> [Located RdrName] diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index 0da8e30f6a..88996e31b1 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -66,7 +66,7 @@ import qualified GHC.LanguageExtensions as LangExt newLocalBndrRn :: Located RdrName -> RnM Name -- Used for non-top-level binders. These should -- never be qualified. -newLocalBndrRn (dL->L loc rdr_name) +newLocalBndrRn (L loc rdr_name) | Just name <- isExact_maybe rdr_name = return name -- This happens in code generated by Template Haskell -- See Note [Binders in Template Haskell] in Convert.hs @@ -127,7 +127,7 @@ checkShadowedRdrNames loc_rdr_names where filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names -- See Note [Binders in Template Haskell] in Convert - get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr) + get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () checkDupAndShadowedNames envs names diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index 35862aeabe..2bb69fa6f9 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -256,7 +256,7 @@ We do not want to extend the substitution with (y -> x |> co); since y is of unlifted type, this would destroy the let/app invariant if (x |> co) was not ok-for-speculation. -But surely (x |> co) is ok-for-speculation, becasue it's a trivial +But surely (x |> co) is ok-for-speculation, because it's a trivial expression, and x's type is also unlifted, presumably. Well, maybe not if you are using unsafe casts. I actually found a case where we had diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs index bd5b3a3055..75c55c698c 100644 --- a/compiler/simplCore/CallArity.hs +++ b/compiler/simplCore/CallArity.hs @@ -162,7 +162,7 @@ The interesting cases of the analysis: Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)} * Let v = rhs in body: In addition to the results from the subexpressions, add all co-calls from - everything that the body calls together with v to everthing that is called + everything that the body calls together with v to everything that is called by v. Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)} * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body @@ -318,7 +318,7 @@ Note [Taking boring variables into account] If we decide that the variable bound in `let x = e1 in e2` is not interesting, the analysis of `e2` will not report anything about `x`. To ensure that `callArityBind` does still do the right thing we have to take that into account -everytime we would be lookup up `x` in the analysis result of `e2`. +every time we would be lookup up `x` in the analysis result of `e2`. * Instead of calling lookupCallArityRes, we return (0, True), indicating that this variable might be called many times with no arguments. * Instead of checking `calledWith x`, we assume that everything can be called diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index fde925063b..620f24c680 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -64,10 +64,11 @@ import FastString import qualified ErrUtils as Err import ErrUtils( Severity(..) ) import UniqSupply -import UniqFM ( UniqFM, mapUFM, filterUFM ) import MonadUtils import NameCache +import NameEnv import SrcLoc +import Data.Bifunctor ( bimap ) import Data.List import Data.Ord import Data.Dynamic @@ -733,17 +734,19 @@ getPackageFamInstEnv = do -- annotations. -- -- See Note [Annotations] -getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) +getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a]) getAnnotations deserialize guts = do hsc_env <- getHscEnv ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) return (deserializeAnns deserialize ann_env) --- | Get at most one annotation of a given type per Unique. -getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) +-- | Get at most one annotation of a given type per annotatable item. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a) getFirstAnnotations deserialize guts - = liftM (mapUFM head . filterUFM (not . null)) - $ getAnnotations deserialize guts + = bimap mod name <$> getAnnotations deserialize guts + where + mod = mapModuleEnv head . filterModuleEnv (const $ not . null) + name = mapNameEnv head . filterNameEnv (not . null) {- Note [Annotations] diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs index f5a4138566..1183e6cf02 100644 --- a/compiler/simplCore/Exitify.hs +++ b/compiler/simplCore/Exitify.hs @@ -431,7 +431,7 @@ To prevent this, we need to recognize exit join points, and then disable inlining. Exit join points, recognizeable using `isExitJoinId` are join points with an -occurence in a recursive group, and can be recognized (after the occurence +occurrence in a recursive group, and can be recognized (after the occurrence analyzer ran!) using `isExitJoinId`. This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, because the lambdas of a non-recursive join point are not considered for @@ -493,7 +493,7 @@ free variables of the join point. We do not just `filter (`elemVarSet` fvs) captured`, as there might be shadowing, and `captured` may contain multiple variables with the same Unique. I -these cases we want to abstract only over the last occurence, hence the `foldr` +these cases we want to abstract only over the last occurrence, hence the `foldr` (with emphasis on the `r`). This is #15110. -} diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index ecad4a585f..500dc7a912 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -371,7 +371,7 @@ That's why we compute So we must *not* postInlineUnconditionally 'g', even though its RHS turns out to be trivial. (I'm assuming that 'g' is - not choosen as a loop breaker.) Why not? Because then we + not chosen as a loop breaker.) Why not? Because then we drop the binding for 'g', which leaves it out of scope in the RULE! @@ -1534,8 +1534,8 @@ occAnalNonRecRhs env bndr bndrs body certainly_inline -- See Note [Cascading inlines] = case occ of - OneOcc { occ_in_lam = in_lam, occ_one_br = one_br } - -> not in_lam && one_br && active && not_stable + OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch } + -> active && not_stable _ -> False is_join_point = isAlwaysTailCalled occ @@ -1783,14 +1783,14 @@ occAnal env (Case scrut bndr ty alts) occ_anal_scrut (Var v) (alt1 : other_alts) | not (null other_alts) || not (isDefaultAlt alt1) - = (mkOneOcc env v True 0, Var v) + = (mkOneOcc env v IsInteresting 0, Var v) -- The 'True' says that the variable occurs in an interesting -- context; the case has at least one non-default alternative occ_anal_scrut (Tick t e) alts | t `tickishScopesLike` SoftScope -- No reason to not look through all ticks here, but only -- for soft-scoped ticks we can do so without having to - -- update returned occurance info (see occAnal) + -- update returned occurrence info (see occAnal) = second (Tick t) $ occ_anal_scrut e alts occ_anal_scrut scrut _alts @@ -1861,7 +1861,7 @@ occAnalApp env (Var fun, args, ticks) n_val_args = valArgCount args n_args = length args - fun_uds = mkOneOcc env fun (n_val_args > 0) n_args + fun_uds = mkOneOcc env fun (if n_val_args > 0 then IsInteresting else NotInteresting) n_args is_exp = isExpandableApp fun n_val_args -- See Note [CONLIKE pragma] in BasicTypes -- The definition of is_exp should match that in Simplify.prepareRhs @@ -2210,7 +2210,7 @@ extendFvs env s Note [Binder swap] ~~~~~~~~~~~~~~~~~~ -The "binder swap" tranformation swaps occurence of the +The "binder swap" tranformation swaps occurrence of the scrutinee of a case for occurrences of the case-binder: (1) case x of b { pi -> ri } @@ -2325,7 +2325,7 @@ as Dead, so we must zap the OccInfo on cb before making the binding x = cb. See #5028. NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier -doesn't use it. So this is only to satisfy the perhpas-over-picky Lint. +doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. Historical note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2475,8 +2475,8 @@ andUDsList = foldl' andUDs emptyDetails mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails mkOneOcc env id int_cxt arity | isLocalId id - = singleton $ OneOcc { occ_in_lam = False - , occ_one_br = True + = singleton $ OneOcc { occ_in_lam = NotInsideLam + , occ_one_br = InOneBranch , occ_int_cxt = int_cxt , occ_tail = AlwaysTailCalled arity } | id `elemVarSet` occ_gbl_scrut env @@ -2535,7 +2535,7 @@ zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo lookupDetails :: UsageDetails -> Id -> OccInfo lookupDetails ud id - | isCoVar id -- We do not currenly gather occurrence info (from types) + | isCoVar id -- We do not currently gather occurrence info (from types) = noOccInfo -- for CoVars, so we must conservatively mark them as used -- See Note [DoO not mark CoVars as dead] | otherwise @@ -2855,7 +2855,7 @@ markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo markMany IAmDead = IAmDead markMany occ = ManyOccs { occ_tail = occ_tail occ } -markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = True } +markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam } markInsideLam occ = occ markNonTailCalled IAmDead = IAmDead @@ -2876,9 +2876,9 @@ orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1 , occ_tail = tail1 }) (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2 , occ_tail = tail2 }) - = OneOcc { occ_one_br = False -- False, because it occurs in both branches - , occ_in_lam = in_lam1 || in_lam2 - , occ_int_cxt = int_cxt1 && int_cxt2 + = OneOcc { occ_one_br = MultipleBranches -- because it occurs in both branches + , occ_in_lam = in_lam1 `mappend` in_lam2 + , occ_int_cxt = int_cxt1 `mappend` int_cxt2 , occ_tail = tail1 `andTailCallInfo` tail2 } orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index da1e31ea6f..223bbcfa97 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -777,7 +777,7 @@ Exammples: It's controlled by a flag (floatConsts), because doing this too early loses opportunities for RULES which (needless to say) are important in some nofib programs (gcd is an example). [SPJ note: -I think this is obselete; the flag seems always on.] +I think this is obsolete; the flag seems always on.] Note [Floating join point bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 5073bbff99..6074d00aa9 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -558,7 +558,7 @@ discarding the arguments to zip. Usually this is fine, but on the LHS of a rule it's not, because 'as' and 'bs' are now not bound on the LHS. -This is a pretty pathalogical example, so I'm not losing sleep over +This is a pretty pathological example, so I'm not losing sleep over it, but the simplest solution was to check sm_inline; if it is False, which it is on the LHS of a rule (see updModeForRules), then don't make use of the strictness info for the function. @@ -1158,12 +1158,12 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs) one_occ IAmDead = True -- Happens in ((\x.1) v) - one_occ (OneOcc { occ_one_br = True -- One textual occurrence - , occ_in_lam = in_lam - , occ_int_cxt = int_cxt }) - | not in_lam = isNotTopLevel top_lvl || early_phase - | otherwise = int_cxt && canInlineInLam rhs - one_occ _ = False + one_occ OneOcc{ occ_one_br = InOneBranch + , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase + one_occ OneOcc{ occ_one_br = InOneBranch + , occ_in_lam = IsInsideLam + , occ_int_cxt = IsInteresting } = canInlineInLam rhs + one_occ _ = False pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env) mode = getMode env @@ -1297,7 +1297,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs -- PRINCIPLE: when we've already simplified an expression once, -- make sure that we only inline it if it's reasonably small. - && (not in_lam || + && (in_lam == NotInsideLam || -- Outside a lambda, we want to be reasonably aggressive -- about inlining into multiple branches of case -- e.g. let x = <non-value> @@ -1306,7 +1306,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs -- the uses in C1, C2 are not 'interesting' -- An example that gets worse if you add int_cxt here is 'clausify' - (isCheapUnfolding unfolding && int_cxt)) + (isCheapUnfolding unfolding && int_cxt == IsInteresting)) -- isCheap => acceptable work duplication; in_lam may be true -- int_cxt to prevent us inlining inside a lambda without some -- good reason. See the notes on int_cxt in preInlineUnconditionally @@ -2251,7 +2251,10 @@ mkCase3 _dflags scrut bndr alts_ty alts -- InIds, so it's crucial that isExitJoinId is only called on freshly -- occ-analysed code. It's not a generic function you can call anywhere. isExitJoinId :: Var -> Bool -isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id) +isExitJoinId id + = isJoinId id + && isOneOcc (idOccInfo id) + && occ_in_lam (idOccInfo id) == IsInsideLam {- Note [Dead binders] diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 569bcfd3dc..2613244696 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -1623,7 +1623,7 @@ wrapJoinCont env cont thing_inside = thing_inside env cont | not (sm_case_case (getMode env)) - -- See Note [Join points wih -fno-case-of-case] + -- See Note [Join points with -fno-case-of-case] = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont @@ -1691,7 +1691,7 @@ We need do make the continuation E duplicable (since we are duplicating it) with mkDuableCont. -Note [Join points wih -fno-case-of-case] +Note [Join points with -fno-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Supose case-of-case is switched off, and we are simplifying @@ -2789,8 +2789,8 @@ addEvals _scrut con vs = go vs the_strs where ppr_with_length list = ppr list <+> parens (text "length =" <+> ppr (length list)) - strdisp MarkedStrict = "MarkedStrict" - strdisp NotMarkedStrict = "NotMarkedStrict" + strdisp MarkedStrict = text "MarkedStrict" + strdisp NotMarkedStrict = text "NotMarkedStrict" zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id zapIdOccInfoAndSetEvald str v = @@ -2965,7 +2965,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont | exprIsTrivial scrut = return (emptyFloats env , extendIdSubst env bndr (DoneEx scrut Nothing)) | otherwise = do { dc_args <- mapM (simplVar env) bs - -- dc_ty_args are aready OutTypes, + -- dc_ty_args are already OutTypes, -- but bs are InBndrs ; let con_app = Var (dataConWorkId dc) `mkTyApps` dc_ty_args diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs index 75fde79d87..e6eb907f19 100644 --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -330,7 +330,7 @@ Examples include: The "representation or a primitive entity" specifies what kind of register is needed and how many bits are required. The data type TyCon.PrimRep -enumerates all the possiblities. +enumerates all the possibilities. data PrimRep = VoidRep diff --git a/compiler/simplStg/StgLiftLams/Analysis.hs b/compiler/simplStg/StgLiftLams/Analysis.hs index 104c2f8ef3..8bcd6f6cb5 100644 --- a/compiler/simplStg/StgLiftLams/Analysis.hs +++ b/compiler/simplStg/StgLiftLams/Analysis.hs @@ -412,7 +412,7 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide is_memoized_rhs StgRhsCon{} = True is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd - -- Don't lift binders occuring as arguments. This would result in complex + -- Don't lift binders occurring as arguments. This would result in complex -- argument expressions which would have to be given a name, reintroducing -- the very allocation at each call site that we wanted to get rid off in -- the first place. diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 8ced5a87c0..56c81ea101 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -699,7 +699,7 @@ specConstrProgram guts = do dflags <- getDynFlags us <- getUniqueSupplyM - annos <- getFirstAnnotations deserializeWithData guts + (_, annos) <- getFirstAnnotations deserializeWithData guts this_mod <- getModule let binds' = reverse $ fst $ initUs us $ do -- Note [Top-level recursive groups] diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index 75e80d0c46..b79a559436 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -576,7 +576,7 @@ Hence, the invariant is this: ************************************************************************ -} --- | Specialise calls to type-class overloaded functions occuring in a program. +-- | Specialise calls to type-class overloaded functions occurring in a program. specProgram :: ModGuts -> CoreM ModGuts specProgram guts@(ModGuts { mg_module = this_mod , mg_rules = local_rules @@ -2107,7 +2107,7 @@ Consider We gather the call info for (f @T $df), and we don't want to drop it when we come across the binding for $df. So we add $df to the floats and continue. But then we have to add $c== to the floats, and so on. -These all float above the binding for 'f', and and now we can +These all float above the binding for 'f', and now we can successfully specialise 'f'. So the DictBinds in (ud_binds :: Bag DictBind) may contain @@ -2378,7 +2378,7 @@ pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs interesting :: InterestingVarFun interesting v = isLocalVar v || (isId v && isDFunId v) -- Very important: include DFunIds /even/ if it is imported - -- Reason: See Note [Avoiding loops], the second exmaple + -- Reason: See Note [Avoiding loops], the second example -- involving an imported dfun. We must know whether -- a dictionary binding depends on an imported dfun, -- in case we try to specialise that imported dfun diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 213064d599..36c613c186 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -881,7 +881,7 @@ To do the injectivity check: 1. We build VarUsages that represent the LHS (rather, the portion of the LHS that is flagged as injective); each usage on the LHS is NotPresent, because we -hvae not yet looked at the RHS. +have not yet looked at the RHS. 2. We also build a VarUsage for the RHS, done by injTyVarUsages. diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 6421be4f16..a448f74e56 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -305,7 +305,7 @@ tcHsBootSigs binds sigs where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where - f (dL->L _ name) + f (L _ name) = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds @@ -340,12 +340,12 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where - ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds] + ips = [ip | (L _ (IPBind _ (Left (L _ ip)) _)) <- ip_binds] - -- I wonder if we should do these one at at time + -- I wonder if we should do these one at a time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr) + tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] @@ -516,7 +516,7 @@ recursivePatSynErr loc binds 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+> pprLoc loc tc_single :: forall thing. @@ -524,7 +524,7 @@ tc_single :: forall thing. -> LHsBind GhcRn -> IsGroupClosed -> TcM thing -> TcM (LHsBinds GhcTcId, thing) tc_single _top_lvl sig_fn _prag_fn - (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) })) + (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) ; thing <- setGblEnv tcg_env thing_inside @@ -563,7 +563,7 @@ mkEdges sig_fn binds keyd_binds = bagToList binds `zip` [0::BKey ..] key_map :: NameEnv BKey -- Which binding it comes from - key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds , bndr <- collectHsBindBinders bind ] ------------------------ @@ -685,8 +685,8 @@ tcPolyCheck prag_fn (CompleteSig { sig_bndr = poly_id , sig_ctxt = ctxt , sig_loc = sig_loc }) - (dL->L loc (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches })) + (L loc (FunBind { fun_id = (L nm_loc name) + , fun_matches = matches })) = setSrcSpan sig_loc $ do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id @@ -703,7 +703,7 @@ tcPolyCheck prag_fn tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ tcExtendNameTyVarEnv tv_prs $ setSrcSpan loc $ - tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau) + tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau) ; let prag_sigs = lookupPragEnv prag_fn name ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -711,7 +711,7 @@ tcPolyCheck prag_fn ; mod <- getModule ; tick <- funBindTicks nm_loc mono_id mod prag_sigs - ; let bind' = FunBind { fun_id = cL nm_loc mono_id + ; let bind' = FunBind { fun_id = L nm_loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc @@ -723,13 +723,13 @@ tcPolyCheck prag_fn , abe_mono = mono_id , abe_prags = SpecPrags spec_prags } - abs_bind = cL loc $ + abs_bind = L loc $ AbsBinds { abs_ext = noExtField , abs_tvs = skol_tvs , abs_ev_vars = ev_vars , abs_ev_binds = [ev_binds] , abs_exports = [export] - , abs_binds = unitBag (cL loc bind') + , abs_binds = unitBag (L loc bind') , abs_sig = True } ; return (unitBag abs_bind, [poly_id]) } @@ -740,7 +740,7 @@ tcPolyCheck _prag_fn sig bind funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [Tickish TcId] funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ] + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str @@ -806,7 +806,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports - abs_bind = cL loc $ + abs_bind = L loc $ AbsBinds { abs_ext = noExtField , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] @@ -1098,7 +1098,7 @@ checkOverloadedSig monomorphism_restriction_applies sig {- Note [Partial type signatures and generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If /any/ of the signatures in the gropu is a partial type signature +If /any/ of the signatures in the group is a partial type signature f :: _ -> Int then we *always* use the InferGen plan, and hence tcPolyInfer. We do this even for a local binding with -XMonoLocalBinds, when @@ -1249,9 +1249,9 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -> [LHsBind GhcRn] -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen - [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name) - , fun_matches = matches - , fun_ext = fvs })] + [ L b_loc (FunBind { fun_id = L nm_loc name + , fun_matches = matches + , fun_ext = fvs })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -1271,11 +1271,11 @@ tcMonoBinds is_rec sig_fn no_gen -- We extend the error context even for a non-recursive -- function so that in type error messages we show the -- type of the thing whose rhs we are type checking - tcMatchesFun (cL nm_loc name) matches exp_ty + tcMatchesFun (L nm_loc name) matches exp_ty ; mono_id <- newLetBndr no_gen name rhs_ty - ; return (unitBag $ cL b_loc $ - FunBind { fun_id = cL nm_loc mono_id, + ; return (unitBag $ L b_loc $ + FunBind { fun_id = L nm_loc mono_id, fun_matches = matches', fun_ext = fvs, fun_co_fn = co_fn, fun_tick = [] }, [MBI { mbi_poly_name = name @@ -1332,7 +1332,7 @@ tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind -- CheckGen is used only for functions with a complete type signature, -- and tcPolyCheck doesn't use tcMonoBinds at all -tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name) +tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name , fun_matches = matches }) | Just (TcIdSig sig) <- sig_fn name = -- There is a type signature. @@ -1420,9 +1420,9 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id)) + ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = cL loc mono_id + ; return ( FunBind { fun_id = L loc mono_id , fun_matches = matches' , fun_co_fn = co_fn , fun_ext = placeHolderNamesTc @@ -1634,7 +1634,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn = [ null theta | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) <- mapMaybe sig_fn (collectHsBindListBinders lbinds) - , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] + , let (_, L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ] has_partial_sigs = not (null partial_sig_mrs) @@ -1650,7 +1650,7 @@ decideGeneralisationPlan dflags lbinds closed sig_fn -- With OutsideIn, all nested bindings are monomorphic -- except a single function binding with a signature one_funbind_with_sig - | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds + | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds , Just (TcIdSig sig) <- sig_fn (unLoc v) = Just (lbind, sig) | otherwise @@ -1679,7 +1679,7 @@ isClosedBndrGroup type_env binds fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = (dL->L _ f) + bindFvs (FunBind { fun_id = L _ f , fun_ext = fvs }) = let open_fvs = get_open_fvs fvs in [(f, open_fvs)] diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 20790200d0..9d2acfc9f7 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -609,7 +609,7 @@ makeSuperClasses, giving us a a second quantified constrait (forall a. a ~# b) BUT this is an unboxed value! And nothing has prepared us for dictionary "functions" that are unboxed. Actually it does just -about work, but the simplier ends up with stuff like +about work, but the simplifier ends up with stuff like case (/\a. eq_sel d) of df -> ...(df @Int)... and fails to simplify that any further. And it doesn't satisfy isPredTy any more. diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 18e71c8803..09a9bb2f6e 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -78,7 +78,7 @@ would implicitly declare (forall b. Ord b => a -> b -> b) (We could use a record decl, but that means changing more of the existing apparatus. -One step at at time!) +One step at a time!) For classes with just one superclass+method, we use a newtype decl instead: diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index a6c44d0c45..3f89e2c033 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -369,7 +369,7 @@ the rest of the instance. The fact that it is suspended is important, because right now, we don't have ThetaTypes for the instances that use deriving clauses (only the standalone-derived ones). -Now we can can collect the type family instances and extend the local instance +Now we can collect the type family instances and extend the local instance environment. At this point, it is safe to run simplifyInstanceContexts on the deriving-clause instance specs, which gives us the ThetaTypes for the deriving-clause instances. Now we can feed all the ThetaTypes to the @@ -1016,7 +1016,7 @@ a poly-kinded typeclass for a poly-kinded datatype. For example: class Category (cat :: k -> k -> *) where newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category -This case is suprisingly tricky. To see why, let's write out what instance GHC +This case is surprisingly tricky. To see why, let's write out what instance GHC will attempt to derive (using -fprint-explicit-kinds syntax): instance Category k1 (T k2 c) where ... @@ -1289,7 +1289,7 @@ When there are no type families, it's quite easy: instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S -When type familes are involved it's trickier: +When type families are involved it's trickier: data family T a b newtype instance T Int a = MkT [a] deriving( Eq, Monad ) diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs index 97dffcd1cf..10c58d502e 100644 --- a/compiler/typecheck/TcDerivInfer.hs +++ b/compiler/typecheck/TcDerivInfer.hs @@ -991,7 +991,7 @@ more complicated it will be reported in a civilised way. Note [Error reporting for deriving clauses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A suprisingly tricky aspect of deriving to get right is reporting sensible +A surprisingly tricky aspect of deriving to get right is reporting sensible error messages. In particular, if simplifyDeriv reaches a constraint that it cannot solve, which might include: diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index d9bd893dc5..725274bbaf 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -509,7 +509,7 @@ isTypeClosedLetBndr = noFreeVarsOfType . idType tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a -- Used for binding the recurive uses of Ids in a binding --- both top-level value bindings and and nested let/where-bindings +-- both top-level value bindings and nested let/where-bindings -- Does not extend the TcBinderStack tcExtendRecIds pairs thing_inside = tc_extend_local_env NotTopLevel @@ -533,7 +533,7 @@ tcExtendSigIds top_lvl sig_ids thing_inside tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed -> [TcId] -> TcM a -> TcM a --- Used for both top-level value bindings and and nested let/where-bindings +-- Used for both top-level value bindings and nested let/where-bindings -- Adds to the TcBinderStack too tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) ids thing_inside diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index ffc054ee0a..00d95c405b 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -2359,7 +2359,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over mb_patsyn_prov :: Maybe SDoc mb_patsyn_prov | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig = Just (vcat [ text "In other words, a successful match on the pattern" , nest 2 $ ppr pat , text "does not provide the constraint" <+> pprParendType pred ]) @@ -2488,7 +2488,7 @@ ctxtFixes has_ambig_tvs pred implics discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig = filterOut (discard name) givens | otherwise = givens diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 712668f372..5560b219ba 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -181,17 +181,15 @@ tcExpr e@(HsLit x lit) res_ty tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar x expr') } -tcExpr (HsSCC x src lbl expr) res_ty +tcExpr (HsPragE x prag expr) res_ty = do { expr' <- tcMonoExpr expr res_ty - ; return (HsSCC x src lbl expr') } - -tcExpr (HsTickPragma x src info srcInfo expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsTickPragma x src info srcInfo expr') } - -tcExpr (HsCoreAnn x src lbl expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn x src lbl expr') } + ; return (HsPragE x (tc_prag prag) expr') } + where + tc_prag :: HsPragE GhcRn -> HsPragE GhcTc + tc_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann + tc_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl + tc_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo + tc_prag (XHsPragE x) = noExtCon x tcExpr (HsOverLit x lit) res_ty = do { lit' <- newOverloadedLit lit res_ty diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index fed20bf810..5d5589df9a 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -714,7 +714,7 @@ other examples where lazy flattening caused problems. Bottom line: FM_Avoid is unused for now (Nov 14). Note: T5321Fun got faster when I disabled FM_Avoid - T5837 did too, but it's pathalogical anyway + T5837 did too, but it's pathological anyway Note [Phantoms in the flattener] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1708,7 +1708,7 @@ is an example; all the constraints here are Givens inert fsk ~ ((fsk3, TF Int), TF Int) Because the incoming given rewrites all the inert givens, we get more and -more duplication in the inert set. But this really only happens in pathalogical +more duplication in the inert set. But this really only happens in pathological casee, so we don't care. diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 8eb86fcec2..f7fbb02aa6 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -358,11 +358,11 @@ gen_Ord_binds loc tycon = do = emptyBag negate_expr = nlHsApp (nlHsVar not_RDR) - lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $ + lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $ negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr) - gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $ + gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $ nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr - gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $ + gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) get_tag con = dataConTag con - fIRST_TAG @@ -381,7 +381,7 @@ gen_Ord_binds loc tycon = do mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs -- Returns a binding op a b = ... compares a and b according to op .... - mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] + mkOrdOp dflags op = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs dflags op) mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs @@ -597,7 +597,7 @@ gen_Enum_binds loc tycon = do occ_nm = getOccString tycon succ_enum dflags - = mk_easy_FunBind loc succ_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -607,7 +607,7 @@ gen_Enum_binds loc tycon = do nlHsIntLit 1])) pred_enum dflags - = mk_easy_FunBind loc pred_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -619,7 +619,7 @@ gen_Enum_binds loc tycon = do (mkIntegralLit (-1 :: Int)))])) to_enum dflags - = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [ nlHsVar a_RDR @@ -628,7 +628,7 @@ gen_Enum_binds loc tycon = do (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon)) enum_from dflags - = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR dflags tycon), @@ -637,7 +637,7 @@ gen_Enum_binds loc tycon = do (nlHsVar (maxtag_RDR dflags tycon)))] enum_from_then dflags - = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ + = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ nlHsPar (enum_from_then_to_Expr @@ -650,7 +650,7 @@ gen_Enum_binds loc tycon = do )) from_enum dflags - = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $ + = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) @@ -766,7 +766,7 @@ gen_Ix_binds loc tycon = do ] enum_range dflags - = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ + = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] $ untag_Expr dflags tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $ @@ -775,7 +775,7 @@ gen_Ix_binds loc tycon = do (nlHsVarApps intDataCon_RDR [bh_RDR])) enum_index dflags - = mk_easy_FunBind loc unsafeIndex_RDR + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR [noLoc (AsPat noExtField (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( @@ -792,7 +792,7 @@ gen_Ix_binds loc tycon = do -- This produces something like `(ch >= ah) && (ch <= bh)` enum_inRange dflags - = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ + = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( untag_Expr dflags tycon [(b_RDR, bh_RDR)] ( untag_Expr dflags tycon [(c_RDR, ch_RDR)] ( @@ -825,7 +825,7 @@ gen_Ix_binds loc tycon = do -------------------------------------------------------------- single_con_range - = mk_easy_FunBind loc range_RDR + = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ noLoc (mkHsComp ListComp stmts con_expr) where @@ -837,7 +837,7 @@ gen_Ix_binds loc tycon = do ---------------- single_con_index - = mk_easy_FunBind loc unsafeIndex_RDR + = mkSimpleGeneratedFunBind loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] -- We need to reverse the order we consider the components in @@ -863,7 +863,7 @@ gen_Ix_binds loc tycon = do ------------------ single_con_inRange - = mk_easy_FunBind loc inRange_RDR + = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] $ if con_arity == 0 @@ -1380,7 +1380,7 @@ gen_data dflags data_type_name constr_names loc rep_tc mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) ------------ gunfold - gunfold_bind = mk_easy_FunBind loc + gunfold_bind = mkSimpleGeneratedFunBind loc gunfold_RDR [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] gunfold_rhs @@ -1409,7 +1409,7 @@ gen_data dflags data_type_name constr_names loc rep_tc to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) ------------ dataTypeOf - dataTypeOf_bind = mk_easy_FunBind + dataTypeOf_bind = mkSimpleGeneratedFunBind loc dataTypeOf_RDR [nlWildPat] @@ -1436,7 +1436,7 @@ gen_data dflags data_type_name constr_names loc rep_tc | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR | otherwise = emptyBag mk_gcast dataCast_RDR gcast_RDR - = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR] + = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR] (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR)) @@ -2019,7 +2019,7 @@ mkFunBindSE arity loc fun pats_and_exprs mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches - = L loc (mkFunBind fun matches) + = L loc (mkFunBind Generated fun matches) -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last @@ -2047,7 +2047,7 @@ mkRdrFunBindEC :: Arity -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindEC arity catch_all - fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches') + fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {} @@ -2071,7 +2071,7 @@ mkRdrFunBindEC arity catch_all mkRdrFunBindSE :: Arity -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindSE arity - fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') + fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare" @@ -2369,7 +2369,7 @@ mkAuxBinderName dflags parent occ_fun {- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~ -We often want to make a top-level auxiliary binding. E.g. for comparison we haev +We often want to make a top-level auxiliary binding. E.g. for comparison we have instance Ord T where compare a b = $con2tag a `compare` $con2tag b diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs index a2eee57947..0e8f0a6d06 100644 --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -980,7 +980,7 @@ tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $ ; traceTc "w_givens are: " $ ppr w_givens ; rem <- runTcSDeriveds $ simpl_top w_givens -- We don't want any insoluble or simple constraints left, but - -- solved implications are ok (and neccessary for e.g. undefined) + -- solved implications are ok (and necessary for e.g. undefined) ; traceTc "rems was:" $ ppr rem ; traceTc "}" empty ; return (isSolvedWC rem, wrp) } } diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index e8b67bbc89..13a3d179b4 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -99,7 +99,7 @@ import Control.Arrow ( second ) -} hsLPatType :: LPat GhcTc -> Type -hsLPatType (dL->L _ p) = hsPatType p +hsLPatType (L _ p) = hsPatType p hsPatType :: Pat GhcTc -> Type hsPatType (ParPat _ pat) = hsLPatType pat @@ -265,7 +265,7 @@ There are three possibilities: So we default it to 'Any' of the right kind. All this works for both type and kind variables (indeed - the two are the same thign). + the two are the same thing). * SkolemiseFlexi: is a special case for the LHS of RULES. See Note [Zonking the LHS of a RULE] @@ -349,7 +349,7 @@ zonkEnvIds (ZonkEnv { ze_id_env = id_env}) -- immediately by creating a TypeEnv zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id -zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env) +zonkLIdOcc env = mapLoc (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; @@ -529,7 +529,7 @@ zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do new_binds <- mapM (wrapLocM zonk_ip_bind) binds let env1 = extendIdZonkEnvRec env - [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds] + [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) where @@ -577,13 +577,13 @@ zonk_bind env (VarBind { var_ext = x , var_rhs = new_expr , var_inline = inl }) } -zonk_bind env bind@(FunBind { fun_id = (dL->L loc var) +zonk_bind env bind@(FunBind { fun_id = L loc var , fun_matches = ms , fun_co_fn = co_fn }) = do { new_var <- zonkIdBndr env var ; (env1, new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = cL loc new_var + ; return (bind { fun_id = L loc new_var , fun_matches = new_ms , fun_co_fn = new_co_fn }) } @@ -610,16 +610,16 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs where zonk_val_bind env lbind | has_sig - , (dL->L loc bind@(FunBind { fun_id = (dL->L mloc mono_id) - , fun_matches = ms - , fun_co_fn = co_fn })) <- lbind + , (L loc bind@(FunBind { fun_id = L mloc mono_id + , fun_matches = ms + , fun_co_fn = co_fn })) <- lbind = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not -- want to complain about a levity-polymorphic binder ; (env', new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env' zonkLExpr ms - ; return $ cL loc $ - bind { fun_id = cL mloc new_mono_id + ; return $ L loc $ + bind { fun_id = L mloc new_mono_id , fun_matches = new_ms , fun_co_fn = new_co_fn } } | otherwise @@ -640,7 +640,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abe_prags = new_prags }) zonk_export _ (XABExport nec) = noExtCon nec -zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) +zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id , psb_args = details , psb_def = lpat , psb_dir = dir })) @@ -649,7 +649,7 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id) ; let details' = zonkPatSynDetails env1 details ; (_env2, dir') <- zonkPatSynDir env1 dir ; return $ PatSynBind x $ - bind { psb_id = cL loc id' + bind { psb_id = L loc id' , psb_args = details' , psb_def = lpat' , psb_dir = dir' } } @@ -684,9 +684,9 @@ zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] zonkLTcSpecPrags env ps = mapM zonk_prag ps where - zonk_prag (dL->L loc (SpecPrag id co_fn inl)) + zonk_prag (L loc (SpecPrag id co_fn inl)) = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } + ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } {- ************************************************************************ @@ -700,13 +700,13 @@ zonkMatchGroup :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> MatchGroup GhcTcId (Located (body GhcTcId)) -> TcM (MatchGroup GhcTc (Located (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms) +zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) = do { ms' <- mapM (zonkMatch env zBody) ms ; arg_tys' <- zonkTcTypesToTypesX env arg_tys ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = cL l ms' + ; return (MG { mg_alts = L l ms' , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec @@ -715,14 +715,12 @@ zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc))) -> LMatch GhcTcId (Located (body GhcTcId)) -> TcM (LMatch GhcTc (Located (body GhcTc))) -zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats - , m_grhss = grhss })) +zonkMatch env zBody (L loc match@(Match { m_pats = pats + , m_grhss = grhss })) = do { (env1, new_pats) <- zonkPats env pats ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) } -zonkMatch _ _ (dL->L _ (XMatch nec)) = noExtCon nec -zonkMatch _ _ _ = panic "zonkMatch: Impossible Match" - -- due to #15884 + ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } +zonkMatch _ _ (L _ (XMatch nec)) = noExtCon nec ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv @@ -730,7 +728,7 @@ zonkGRHSs :: ZonkEnv -> GRHSs GhcTcId (Located (body GhcTcId)) -> TcM (GRHSs GhcTc (Located (body GhcTc))) -zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do +zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS xx guarded rhs) @@ -739,7 +737,7 @@ zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do return (GRHS xx new_guarded new_rhs) zonk_grhs (XGRHS nec) = noExtCon nec new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (cL l new_binds)) + return (GRHSs x new_grhss (L l new_binds)) zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec {- @@ -757,9 +755,9 @@ zonkExpr :: ZonkEnv -> HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr -zonkExpr env (HsVar x (dL->L l id)) +zonkExpr env (HsVar x (L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar x (cL l (zonkIdOcc env id))) + return (HsVar x (L l (zonkIdOcc env id))) zonkExpr _ e@(HsConLikeOut {}) = return e @@ -842,13 +840,11 @@ zonkExpr env (ExplicitTuple x tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args ; return (ExplicitTuple x new_tup_args boxed) } where - zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (cL l (Present x e')) } - zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t - ; return (cL l (Missing t')) } - zonk_tup_arg (dL->L _ (XTupArg nec)) = noExtCon nec - zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match" - -- due to #15884 + zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e + ; return (L l (Present x e')) } + zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t + ; return (L l (Missing t')) } + zonk_tup_arg (L _ (XTupArg nec)) = noExtCon nec zonkExpr env (ExplicitSum args alt arity expr) @@ -884,15 +880,15 @@ zonkExpr env (HsMultiIf ty alts) ; return $ GRHS x guard' expr' } zonk_alt (XGRHS nec) = noExtCon nec -zonkExpr env (HsLet x (dL->L l binds) expr) +zonkExpr env (HsLet x (L l binds) expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet x (cL l new_binds) new_expr) + return (HsLet x (L l new_binds) new_expr) -zonkExpr env (HsDo ty do_or_lc (dL->L l stmts)) +zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts new_ty <- zonkTcTypeToTypeX env ty - return (HsDo new_ty do_or_lc (cL l new_stmts)) + return (HsDo new_ty do_or_lc (L l new_stmts)) zonkExpr env (ExplicitList ty wit exprs) = do (env1, new_wit) <- zonkWit env wit @@ -936,18 +932,9 @@ zonkExpr env (ArithSeq expr wit info) where zonkWit env Nothing = return (env, Nothing) zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln -zonkExpr env (HsSCC x src lbl expr) +zonkExpr env (HsPragE x prag expr) = do new_expr <- zonkLExpr env expr - return (HsSCC x src lbl new_expr) - -zonkExpr env (HsTickPragma x src info srcInfo expr) - = do new_expr <- zonkLExpr env expr - return (HsTickPragma x src info srcInfo new_expr) - --- hdaume: core annotations -zonkExpr env (HsCoreAnn x src lbl expr) - = do new_expr <- zonkLExpr env expr - return (HsCoreAnn x src lbl new_expr) + return (HsPragE x prag new_expr) -- arrow notation extensions zonkExpr env (HsProc x pat body) @@ -1053,15 +1040,15 @@ zonkCmd env (HsCmdIf x eCond ePred cThen cElse) zonkWit env Nothing = return (env, Nothing) zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w -zonkCmd env (HsCmdLet x (dL->L l binds) cmd) +zonkCmd env (HsCmdLet x (L l binds) cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (cL l new_binds) new_cmd) + return (HsCmdLet x (L l new_binds) new_cmd) -zonkCmd env (HsCmdDo ty (dL->L l stmts)) +zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdDo new_ty (cL l new_stmts)) + return (HsCmdDo new_ty (L l new_stmts)) zonkCmd _ (XCmd nec) = noExtCon nec @@ -1244,9 +1231,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt x (dL->L l binds)) +zonkStmt env _ (LetStmt x (L l binds)) = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (cL l new_binds)) + return (env1, LetStmt x (L l new_binds)) zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op) = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op @@ -1312,21 +1299,21 @@ zonkRecFields env (HsRecFields flds dd) = do { flds' <- mapM zonk_rbind flds ; return (HsRecFields flds' dd) } where - zonk_rbind (dL->L l fld) + zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldLbl = new_id + ; return (L l (fld { hsRecFieldLbl = new_id , hsRecFieldArg = new_expr })) } zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId] -> TcM [LHsRecUpdField GhcTcId] zonkRecUpdFields env = mapM zonk_rbind where - zonk_rbind (dL->L l fld) + zonk_rbind (L l fld) = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id - , hsRecFieldArg = new_expr })) } + ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id + , hsRecFieldArg = new_expr })) } ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a @@ -1360,9 +1347,9 @@ zonk_pat env (WildPat ty) (text "In a wildcard pattern") ; return (env, WildPat ty') } -zonk_pat env (VarPat x (dL->L l v)) +zonk_pat env (VarPat x (L l v)) = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) } + ; return (extendIdZonkEnv1 env v', VarPat x (L l v')) } zonk_pat env (LazyPat x pat) = do { (env', pat') <- zonkPat env pat @@ -1372,10 +1359,10 @@ zonk_pat env (BangPat x pat) = do { (env', pat') <- zonkPat env pat ; return (env', BangPat x pat') } -zonk_pat env (AsPat x (dL->L loc v) pat) +zonk_pat env (AsPat x (L loc v) pat) = do { v' <- zonkIdBndr env v ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat x (cL loc v') pat') } + ; return (env', AsPat x (L loc v') pat') } zonk_pat env (ViewPat ty expr pat) = do { expr' <- zonkLExpr env expr @@ -1411,7 +1398,7 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys , pat_binds = binds , pat_args = args , pat_wrap = wrapper - , pat_con = (dL->L _ con) }) + , pat_con = L _ con }) = ASSERT( all isImmutableTyVar tyvars ) do { new_tys <- mapM (zonkTcTypeToTypeX env) tys @@ -1447,7 +1434,7 @@ zonk_pat env (SigPat ty pat hs_ty) ; (env', pat') <- zonkPat env pat ; return (env', SigPat ty' pat' hs_ty) } -zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) +zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr ; (env2, mb_neg') <- case mb_neg of Nothing -> return (env1, Nothing) @@ -1455,9 +1442,9 @@ zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr) ; lit' <- zonkOverLit env2 lit ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') } + ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } -zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) +zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) = do { (env1, e1') <- zonkSyntaxExpr env e1 ; (env2, e2') <- zonkSyntaxExpr env1 e2 ; n' <- zonkIdBndr env2 n @@ -1465,7 +1452,7 @@ zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2) ; lit2' <- zonkOverLit env2 lit2 ; ty' <- zonkTcTypeToTypeX env2 ty ; return (extendIdZonkEnv1 env2 n', - NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') } + NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } zonk_pat env (CoPat x co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn @@ -1491,8 +1478,8 @@ zonkConStuff env (InfixCon p1 p2) zonkConStuff env (RecCon (HsRecFields rpats dd)) = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats) - ; let rpats' = zipWith (\(dL->L l rp) p' -> - cL l (rp { hsRecFieldArg = p' })) + ; let rpats' = zipWith (\(L l rp) p' -> + L l (rp { hsRecFieldArg = p' })) rpats pats' ; return (env', RecCon (HsRecFields rpats' dd)) } -- Field selectors have declared types; hence no zonking @@ -1544,13 +1531,11 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} , rd_lhs = new_lhs , rd_rhs = new_rhs } } where - zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v))) + zonk_tm_bndr env (L l (RuleBndr x (L loc v))) = do { (env', v') <- zonk_it env v - ; return (env', cL l (RuleBndr x (cL loc v'))) } - zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" - zonk_tm_bndr _ (dL->L _ (XRuleBndr nec)) = noExtCon nec - zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match" - -- due to #15884 + ; return (env', L l (RuleBndr x (L loc v'))) } + zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" + zonk_tm_bndr _ (L _ (XRuleBndr nec)) = noExtCon nec zonk_it env v | isId v = do { v' <- zonkIdBndr env v diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 4ed472386c..9a5d745dea 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -352,10 +352,10 @@ tcDerivStrategy :: tcDerivStrategy mb_lds = case mb_lds of Nothing -> boring_case Nothing - Just (dL->L loc ds) -> + Just (L loc ds) -> setSrcSpan loc $ do (ds', tvs) <- tc_deriv_strategy ds - pure (Just (cL loc ds'), tvs) + pure (Just (L loc ds'), tvs) where tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar]) @@ -1323,7 +1323,7 @@ saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) -- Precondition for (saturateFamApp ty kind): -- tcTypeKind ty = kind -- --- If 'ty' is an unsaturated family application wtih trailing +-- If 'ty' is an unsaturated family application with trailing -- invisible arguments, instanttiate them. -- See Note [saturateFamApp] @@ -1559,7 +1559,7 @@ very convenient to typecheck instance types like any other HsSigType. Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's better to reject in checkValidType. If we say that the body kind should be '*' we risk getting TWO error messages, one saying that Eq -[a] doens't have kind '*', and one saying that we need a Constraint to +[a] doesn't have kind '*', and one saying that we need a Constraint to the left of the outer (=>). How do we figure out the right body kind? Well, it's a bit of a diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 6b69928419..a2aa82e51b 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -604,7 +604,7 @@ we keep? More subtle than you might think! and can be reported as redundant. See Note [Tracking redundant constraints] in TcSimplify. - It transpires that using the outermost one is reponsible for an + It transpires that using the outermost one is responsible for an 8% performance improvement in nofib cryptarithm2, compared to just rolling the dice. I didn't investigate why. @@ -1582,7 +1582,7 @@ inertsCanDischarge inerts tv rhs fr keep_deriv ev_i | Wanted WOnly <- ctEvFlavour ev_i -- inert is [W] , (Wanted WDeriv, _) <- fr -- work item is [WD] - = True -- Keep a derived verison of the work item + = True -- Keep a derived version of the work item | otherwise = False -- Work item is fully discharged diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs index 5a33300918..e1cf64f731 100644 --- a/compiler/typecheck/TcOrigin.hs +++ b/compiler/typecheck/TcOrigin.hs @@ -504,8 +504,7 @@ exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" -exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" @@ -514,7 +513,6 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e -exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" exprCtOrigin (XExpr nec) = noExtCon nec diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 6d68cd5904..61e8b21597 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -302,11 +302,11 @@ tc_lpat :: LPat GhcRn -> PatEnv -> TcM a -> TcM (LPat GhcTcId, a) -tc_lpat (dL->L span pat) pat_ty penv thing_inside +tc_lpat (L span pat) pat_ty penv thing_inside = setSrcSpan span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) thing_inside - ; return (cL span pat', res) } + ; return (L span pat', res) } tc_lpats :: PatEnv -> [LPat GhcRn] -> [ExpSigmaType] @@ -326,11 +326,11 @@ tc_pat :: PatEnv -> TcM (Pat GhcTcId, -- Translated pattern a) -- Result of thing inside -tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside +tc_pat penv (VarPat x (L l name)) pat_ty thing_inside = do { (wrap, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) } + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } tc_pat penv (ParPat x pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -361,7 +361,7 @@ tc_pat _ (WildPat _) pat_ty thing_inside ; pat_ty <- expTypeToType pat_ty ; return (WildPat pat_ty, res) } -tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside +tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id) @@ -374,7 +374,7 @@ tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty, + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside @@ -523,7 +523,7 @@ tc_pat penv (LitPat x simple_lit) pat_ty thing_inside -- where lit_ty is the type of the overloaded literal 5. -- -- When there is no negation, neg_lit_ty and lit_ty are the same -tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside +tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside = do { let orig = LiteralOrigin over_lit ; ((lit', mb_neg'), eq') <- tcSyntaxOp orig eq [SynType pat_ty, SynAny] @@ -541,7 +541,7 @@ tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside ; res <- thing_inside ; pat_ty <- readExpType pat_ty - ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) } + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } {- Note [NPlusK patterns] @@ -572,8 +572,8 @@ AST is used for the subtraction operation. -} -- See Note [NPlusK patterns] -tc_pat penv (NPlusKPat _ (dL->L nm_loc name) - (dL->L loc lit) _ ge minus) pat_ty +tc_pat penv (NPlusKPat _ (L nm_loc name) + (L loc lit) _ ge minus) pat_ty thing_inside = do { pat_ty <- expTypeToType pat_ty ; let orig = LiteralOrigin lit @@ -603,7 +603,7 @@ tc_pat penv (NPlusKPat _ (dL->L nm_loc name) ; let minus'' = minus' { syn_res_wrap = minus_wrap <.> syn_res_wrap minus' } - pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2' + pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' ge' minus'' ; return (pat', res) } @@ -712,7 +712,7 @@ tcConPat :: PatEnv -> Located Name -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside +tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside = do { con_like <- tcLookupConLike con_name ; case con_like of RealDataCon data_con -> tcDataConPat penv con_lname data_con @@ -725,13 +725,13 @@ tcDataConPat :: PatEnv -> Located Name -> DataCon -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcDataConPat penv (dL->L con_span con_name) data_con pat_ty +tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con - header = cL con_span (RealDataCon data_con) + header = L con_span (RealDataCon data_con) -- Instantiate the constructor type variables [a->ty] -- This may involve doing a family-instance coercion, @@ -821,7 +821,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn -> ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTcId, a) -tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside +tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn ; (subst, univ_tvs') <- newMetaTyVars univ_tvs @@ -858,7 +858,7 @@ tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) - ; let res_pat = ConPatOut { pat_con = cL con_span $ PatSynCon pat_syn, + ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn, pat_tvs = ex_tvs', pat_dicts = prov_dicts', pat_binds = ev_binds, @@ -988,19 +988,16 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside where tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTcId (LPat GhcTcId)) - tc_field (dL->L l (HsRecField (dL->L loc - (FieldOcc sel (dL->L lr rdr))) pat pun)) + tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside - ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat' + ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' pun), res) } - tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _ + tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _ = panic "tcConArgs" - tc_field _ _ _ = panic "tc_field: Impossible Match" - -- due to #15884 find_field_ty :: Name -> FieldLabelString -> TcM TcType @@ -1101,7 +1098,7 @@ So for now I'm just insisting on type *equality* in patterns. No subsumption. Old notes about desugaring, at a time when pattern coercions were handled: -A SigPat is a type coercion and must be handled one at at time. We can't +A SigPat is a type coercion and must be handled one at a time. We can't combine them unless the type of the pattern inside is identical, and we don't bother to check for that. For example: diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 746b48401b..1c39801f2f 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -81,7 +81,7 @@ tcPatSynDecl psb mb_sig recoverPSB :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = (dL->L _ name) +recoverPSB (PSB { psb_id = L _ name , psb_args = details }) = do { matcher_name <- newImplicitBinder name mkMatcherOcc ; let placeholder = AConLike $ PatSynCon $ @@ -135,7 +135,7 @@ pattern.) But it'll do for now. tcInferPatSynDecl :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) -tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details +tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir }) = addPatSynCtxt lname $ do { traceTc "tcInferPatSynDecl {" $ ppr name @@ -153,7 +153,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details mk_named_tau arg = (getName arg, mkSpecForAllTys ex_tvs (varType arg)) -- The mkSpecForAllTys is important (#14552), albeit - -- slightly artifical (there is no variable with this funny type). + -- slightly artificial (there is no variable with this funny type). -- We do not want to quantify over variable (alpha::k) -- that mention the existentially-bound type variables -- ex_tvs in its kind k. @@ -307,7 +307,7 @@ and is not implicitly instantiated. So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and marginally less efficient, if the builder/martcher are not inlined. -See also Note [Lift equality constaints when quantifying] in TcType +See also Note [Lift equality constraints when quantifying] in TcType Note [Coercions that escape] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -341,7 +341,7 @@ is not very helpful, but at least we don't get a Lint error. tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPatSynInfo -> TcM (LHsBinds GhcTc, TcGblEnv) -tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details +tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } TPSI{ patsig_implicit_bndrs = implicit_tvs , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta @@ -569,12 +569,12 @@ collectPatSynArgInfo details = splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) splitRecordPatSyn (RecordPatSynField - { recordPatSynPatVar = (dL->L _ patVar) - , recordPatSynSelectorId = (dL->L _ selId) }) + { recordPatSynPatVar = L _ patVar + , recordPatSynSelectorId = L _ selId }) = (patVar, selId) addPatSynCtxt :: Located Name -> TcM a -> TcM a -addPatSynCtxt (dL->L loc name) thing_inside +addPatSynCtxt (L loc name) thing_inside = setSrcSpan loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ @@ -685,7 +685,7 @@ tcPatSynMatcher :: Located Name -> TcType -> TcM ((Id, Bool), LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynMatcher (dL->L loc name) lpat +tcPatSynMatcher (L loc name) lpat (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty @@ -726,9 +726,9 @@ tcPatSynMatcher (dL->L loc name) lpat else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] body = mkLHsWrap (mkWpLet req_ev_binds) $ - cL (getLoc lpat) $ + L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = cL (getLoc lpat) cases + MG{ mg_alts = L (getLoc lpat) cases , mg_ext = MatchGroupTc [pat_ty] res_ty , mg_origin = Generated } @@ -739,18 +739,18 @@ tcPatSynMatcher (dL->L loc name) lpat , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty , mg_origin = Generated } - match = mkMatch (mkPrefixFunRhs (cL loc name)) [] + match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (noLoc (EmptyLocalBinds noExtField)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = cL (getLoc match) [match] + mg = MG{ mg_alts = L (getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } ; let bind = FunBind{ fun_ext = emptyNameSet - , fun_id = cL loc matcher_id + , fun_id = L loc matcher_id , fun_matches = mg , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -786,7 +786,7 @@ mkPatSynBuilderId :: HsPatSynDir a -> Located Name -> [TyVarBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (dL->L _ name) +mkPatSynBuilderId dir (L _ name) univ_bndrs req_theta ex_bndrs prov_theta arg_tys pat_ty | isUnidirectional dir @@ -812,7 +812,7 @@ mkPatSynBuilderId dir (dL->L _ name) tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in PatSyn -tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) +tcPatSynBuilderBind (PSB { psb_id = L loc name , psb_def = lpat , psb_dir = dir , psb_args = details }) @@ -840,7 +840,7 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) | otherwise = match_group bind = FunBind { fun_ext = placeHolderNamesTc - , fun_id = cL loc (idName builder_id) + , fun_id = L loc (idName builder_id) , fun_matches = match_group' , fun_co_fn = idHsWrapper , fun_tick = [] } @@ -864,9 +864,9 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) mk_mg body = mkMatchGroup Generated [builder_match] where - builder_args = [cL loc (VarPat noExtField (cL loc n)) - | (dL->L loc n) <- args] - builder_match = mkMatch (mkPrefixFunRhs (cL loc name)) + builder_args = [L loc (VarPat noExtField (L loc n)) + | L loc n <- args] + builder_match = mkMatch (mkPrefixFunRhs (L loc name)) builder_args body (noLoc (EmptyLocalBinds noExtField)) @@ -878,9 +878,8 @@ tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name) add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn) -> MatchGroup GhcRn (LHsExpr GhcRn) add_dummy_arg mg@(MG { mg_alts = - (dL->L l [dL->L loc - match@(Match { m_pats = pats })]) }) - = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] } + (L l [L loc match@(Match { m_pats = pats })]) }) + = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] } add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec @@ -926,9 +925,9 @@ tcPatToExpr name args pat = go pat -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat GhcRn] -> Either MsgDoc (HsExpr GhcRn) - mkPrefixConExpr lcon@(dL->L loc _) pats + mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats - ; return (foldl' (\x y -> HsApp noExtField (cL loc x) y) + ; return (foldl' (\x y -> HsApp noExtField (L loc x) y) (HsVar noExtField lcon) exprs) } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) @@ -938,7 +937,7 @@ tcPatToExpr name args pat = go pat ; return (RecordCon noExtField con exprFields) } go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) - go (dL->L loc p) = cL loc <$> go1 p + go (L loc p) = L loc <$> go1 p go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) go1 (ConPatIn con info) @@ -950,9 +949,9 @@ tcPatToExpr name args pat = go pat go1 (SigPat _ pat _) = go1 (unLoc pat) -- See Note [Type signatures and the builder expression] - go1 (VarPat _ (dL->L l var)) + go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars - = return $ HsVar noExtField (cL l var) + = return $ HsVar noExtField (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat @@ -969,7 +968,7 @@ tcPatToExpr name args pat = go pat (noLoc expr) } go1 (LitPat _ lit) = return $ HsLit noExtField lit - go1 (NPat _ (dL->L _ n) mb_neg _) + go1 (NPat _ (L _ n) mb_neg _) | Just neg <- mb_neg = return $ unLoc $ nlHsSyntaxApps neg [noLoc (HsOverLit noExtField n)] | otherwise = return $ HsOverLit noExtField n @@ -1142,7 +1141,7 @@ tcCollectEx pat = go pat = mergeMany . map goRecFd $ flds goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar]) - goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p + goRecFd (L _ HsRecField{ hsRecFieldArg = p }) = go p merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2) mergeMany = foldr merge empty diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 4d1d32f8a5..d2235e5bd8 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -163,7 +163,7 @@ tcRnModule :: HscEnv -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)} + parsedModule@HsParsedModule {hpm_module= L loc this_module} | RealSrcSpan real_loc <- loc = withTiming dflags (text "Renamer/typechecker"<+>brackets (ppr this_mod)) @@ -186,7 +186,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax pair :: (Module, SrcSpan) pair@(this_mod,_) - | Just (dL->L mod_loc mod) <- hsmodName this_module + | Just (L mod_loc mod) <- hsmodName this_module = (mkModule this_pkg mod, mod_loc) | otherwise -- 'module M where' is omitted @@ -205,7 +205,7 @@ tcRnModuleTcRnM :: HscEnv tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = - (dL->L loc (HsModule maybe_mod export_ies + (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files @@ -232,7 +232,7 @@ tcRnModuleTcRnM hsc_env mod_sum addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (dL->L _ idecl) = + let { simplifyImport (L _ idecl) = ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl) } ; raw_sig_imports <- liftIO @@ -242,7 +242,7 @@ tcRnModuleTcRnM hsc_env mod_sum $ implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) - ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc + ; let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) { ideclHiding = Just (False, noLoc [])} ; mkImport _ = panic "mkImport" } @@ -256,7 +256,7 @@ tcRnModuleTcRnM hsc_env mod_sum -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns let { tcg_env1 = case mod_deprec of - Just (dL->L _ txt) -> + Just (L _ txt) -> tcg_env {tcg_warns = WarnAll txt} Nothing -> tcg_env } @@ -552,7 +552,7 @@ tc_rn_src_decls ds else do { (th_group, th_group_tail) <- findSplice th_ds ; case th_group_tail of { Nothing -> return () - ; Just (SpliceDecl _ (dL->L loc _) _, _) -> + ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpan loc $ addErr (text ("Declaration splices are not " @@ -588,7 +588,7 @@ tc_rn_src_decls ds { Nothing -> return (tcg_env, tcl_env, lie1) -- If there's a splice, we must carry on - ; Just (SpliceDecl _ (dL->L _ splice) _, rest_ds) -> + ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> do { -- We need to simplify any constraints from the previous declaration -- group, or else we might reify metavariables, as in #16980. @@ -681,7 +681,7 @@ tcRnHsBootDecls hsc_src decls ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: HscSource -> String -> Located decl -> TcM () -badBootDecl hsc_src what (dL->L loc _) +badBootDecl hsc_src what (L loc _) = addErrAt loc (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of @@ -874,7 +874,7 @@ checkHiBootIface' -- that modifying boot_dfun, to make local_boot_fun. | otherwise - = setSrcSpan (getLoc (getName boot_dfun)) $ + = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ do { traceTc "check_cls_inst" $ vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) @@ -1747,7 +1747,7 @@ check_main dflags tcg_env explicit_mod_hdr ; (ev_binds, main_expr) <- checkConstraints skol_info [] [] $ addErrCtxt mainCtxt $ - tcMonoExpr (cL loc (HsVar noExtField (cL loc main_name))) + tcMonoExpr (L loc (HsVar noExtField (L loc main_name))) (mkCheckExpType io_ty) -- See Note [Root-main Id] @@ -2057,53 +2057,53 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) -- An expression typed at the prompt is treated very specially -tcUserStmt (dL->L loc (BodyStmt _ expr _ _)) +tcUserStmt (L loc (BodyStmt _ expr _ _)) = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO ; uniq <- newUnique ; interPrintName <- getInteractivePrintName ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr + matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr (noLoc emptyLocalBinds)] -- [it = expr] - the_bind = cL loc $ (mkTopFunBind FromSource - (cL loc fresh_it) matches) + the_bind = L loc $ (mkTopFunBind FromSource + (L loc fresh_it) matches) { fun_ext = fvs } -- Care here! In GHCi the expression might have -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = cL loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField + let_stmt = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e] - bind_stmt = cL loc $ BindStmt noExtField - (cL loc (VarPat noExtField (cL loc fresh_it))) + bind_stmt = L loc $ BindStmt noExtField + (L loc (VarPat noExtField (L loc fresh_it))) (nlHsApp ghciStep rn_expr) (mkRnSyntaxExpr bindIOName) noSyntaxExpr -- [; print it] - print_it = cL loc $ BodyStmt noExtField + print_it = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr -- NewA - no_it_a = cL loc $ BodyStmt noExtField (nlHsApps bindIOName + no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName [rn_expr , nlHsVar interPrintName]) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_b = cL loc $ BodyStmt noExtField (rn_expr) + no_it_b = L loc $ BodyStmt noExtField (rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr - no_it_c = cL loc $ BodyStmt noExtField + no_it_c = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar interPrintName) rn_expr) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2203,7 +2203,7 @@ But for naked expressions, you will have In an equation for ‘x’: x = putStrLn True -} -tcUserStmt rdr_stmt@(dL->L loc _) +tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv @@ -2214,8 +2214,8 @@ tcUserStmt rdr_stmt@(dL->L loc _) ; ghciStep <- getGhciStepIO ; let gi_stmt - | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt - = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 + | (L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt + = L loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2 | otherwise = rn_stmt ; opt_pr_flag <- goptM Opt_PrintBindResult @@ -2237,7 +2237,7 @@ tcUserStmt rdr_stmt@(dL->L loc _) ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM ; return stuff } where - print_v = cL loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) + print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) (nlHsVar v)) (mkRnSyntaxExpr thenIOName) noSyntaxExpr @@ -2594,7 +2594,7 @@ getModuleInterface hsc_env mod tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (dL->L loc rdr_name) +tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ setSrcSpan loc $ do { -- If the identifier is a constructor (begins with an diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index a4ef692c58..0f0067ab5d 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -254,7 +254,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod fix_faminst avail = avail -exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod +exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do ie_avails <- accumExports do_litem rdr_items let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families return (Just ie_avails, final_exports) @@ -280,7 +280,7 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod exports_from_item :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) exports_from_item (ExportAccum occs earlier_mods) - (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod))) + (L loc ie@(IEModuleContents _ lmod@(L _ mod))) | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M = do { warnIfFlag Opt_WarnDuplicateExports True (dupModuleExport mod) ; @@ -317,13 +317,13 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod , ppr new_exports ]) ; return (Just ( ExportAccum occs' mods - , ( cL loc (IEModuleContents noExtField lmod) + , ( L loc (IEModuleContents noExtField lmod) , new_exports))) } - exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie) + exports_from_item acc@(ExportAccum occs mods) (L loc ie) | isDoc ie = do new_ie <- lookup_doc_ie ie - return (Just (acc, (cL loc new_ie, []))) + return (Just (acc, (L loc new_ie, []))) | otherwise = do (new_ie, avail) <- lookup_ie ie @@ -334,17 +334,17 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod occs' <- check_occs ie occs [avail] return (Just ( ExportAccum occs' mods - , (cL loc new_ie, [avail]))) + , (L loc new_ie, [avail]))) ------------- lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (dL->L l rdr)) + lookup_ie (IEVar _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExtField (cL l (replaceWrappedName rdr name)), avail) + return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) - lookup_ie (IEThingAbs _ (dL->L l rdr)) + lookup_ie (IEThingAbs _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExtField (cL l (replaceWrappedName rdr name)) + return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) , avail) lookup_ie ie@(IEThingAll _ n') @@ -376,18 +376,18 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] -> RnM (Located Name, [LIEWrappedName Name], [Name], [Located FieldLabel]) - lookup_ie_with (dL->L l rdr) sub_rdrs + lookup_ie_with (L l rdr) sub_rdrs = do name <- lookupGlobalOccRn $ ieWrappedName rdr (non_flds, flds) <- lookupChildrenExport name sub_rdrs if isUnboundName name - then return (cL l name, [], [name], []) - else return (cL l name, non_flds + then return (L l name, [], [name], []) + else return (L l name, non_flds , map (ieWrappedName . unLoc) non_flds , flds) lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (dL->L l rdr) = + lookup_ie_all ie (L l rdr) = do name <- lookupGlobalOccRn $ ieWrappedName rdr let gres = findChildren kids_env name (non_flds, flds) = classifyGREs gres @@ -401,7 +401,7 @@ exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) - return (cL l name, non_flds, flds) + return (L l name, non_flds, flds) ------------- lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn) @@ -530,8 +530,8 @@ lookupChildrenExport spec_parent rdr_items = case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n - ; return (Left (cL l (IEName (cL l ub))))} - FoundFL fls -> return $ Right (cL (getLoc n) fls) + ; return (Left (L l (IEName (L l ub))))} + FoundFL fls -> return $ Right (L (getLoc n) fls) FoundName par name -> do { checkPatSynParent spec_parent par name ; return $ Left (replaceLWrappedName n name) } diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 3442e8729a..ec4d38fc10 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -840,31 +840,28 @@ setSrcSpan (RealSrcSpan real_loc) thing_inside -- Don't overwrite useful info with useless: setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside -addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b -addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a +addLocM :: (a -> TcM b) -> Located a -> TcM b +addLocM fn (L loc a) = setSrcSpan loc $ fn a -wrapLocM :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b +wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (cL loc b) } -wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) => - (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c) -wrapLocFstM fn (dL->L loc a) = +wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a + ; return (L loc b) } + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a - return (cL loc b, c) + return (L loc b, c) -wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) => - (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c) -wrapLocSndM fn (dL->L loc a) = +wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a - return (b, cL loc c) + return (b, L loc c) -wrapLocM_ :: HasSrcSpan a => - (SrcSpanLess a -> TcM ()) -> a -> TcM () -wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a) +wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () +wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) -- Reporting errors diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 59f9b45617..eb940aa1ee 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -474,7 +474,7 @@ creating a new EvVar when we have a new goal that we have solved in the past. But in particular, we can use it to create *recursive* dictionaries. -The simplest, degnerate case is +The simplest, degenerate case is instance C [a] => C [a] where ... If we have [W] d1 :: C [x] @@ -2859,7 +2859,7 @@ implications. Consider a ~ F b, forall c. b~Int => blah If we have F b ~ fsk in the flat-cache, and we push that into the nested implication, we might miss that F b can be rewritten to F Int, -and hence perhpas solve it. Moreover, the fsk from outside is +and hence perhaps solve it. Moreover, the fsk from outside is flattened out after solving the outer level, but and we don't do that flattening recursively. -} @@ -2881,7 +2881,7 @@ nestTcS (TcS thing_inside) ; new_inerts <- TcM.readTcRef new_inert_var - -- we want to propogate the safe haskell failures + -- we want to propagate the safe haskell failures ; let old_ic = inert_cans inerts new_ic = inert_cans new_inerts nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } @@ -2978,7 +2978,7 @@ Consider forall b. empty => Eq [a] We solve the simple (Eq [a]), under nestTcS, and then turn our attention to the implications. It's definitely fine to use the solved dictionaries on -the inner implications, and it can make a signficant performance difference +the inner implications, and it can make a significant performance difference if you do so. -} diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index b4ef967fcb..1e284ec0a7 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -123,7 +123,7 @@ for two reasons: may actually give rise to f :: forall k. forall (f::k -> *) (a:k). f a -> f a So the sig_tvs will be [k,f,a], but only f,a are scoped. - NB: the scoped ones are not necessarily the *inital* ones! + NB: the scoped ones are not necessarily the *initial* ones! * Even aside from kind polymorphism, there may be more instantiated type variables than lexically-scoped ones. For example: diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 945e496db7..c2803571cf 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -431,6 +431,39 @@ When a variable is used, we compare -} +-- | We only want to produce warnings for TH-splices if the user requests so. +-- See Note [Warnings for TH splices]. +getThSpliceOrigin :: TcM Origin +getThSpliceOrigin = do + warn <- goptM Opt_EnableThSpliceWarnings + if warn then return FromSource else return Generated + +{- Note [Warnings for TH splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only produce warnings for TH splices when the user requests so +(-fenable-th-splice-warnings). There are multiple reasons: + + * It's not clear that the user that compiles a splice is the author of the code + that produces the warning. Think of the situation where she just splices in + code from a third-party library that produces incomplete pattern matches. + In this scenario, the user isn't even able to fix that warning. + * Gathering information for producing the warnings (pattern-match check + warnings in particular) is costly. There's no point in doing so if the user + is not interested in those warnings. + +That's why we store Origin flags in the Haskell AST. The functions from ThToHs +take such a flag and depending on whether TH splice warnings were enabled or +not, we pass FromSource (if the user requests warnings) or Generated +(otherwise). This is implemented in getThSpliceOrigin. + +For correct pattern-match warnings it's crucial that we annotate the Origin +consistently (#17270). In the future we could offer the Origin as part of the +TH AST. That would enable us to give quotes from the current module get +FromSource origin, and/or third library authors to tag certain parts of +generated code as FromSource to enable warnings. That effort is tracked in +#14838. +-} + {- ************************************************************************ * * @@ -686,15 +719,16 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do runQResult :: (a -> String) - -> (SrcSpan -> a -> b) + -> (Origin -> SrcSpan -> a -> b) -> (ForeignHValue -> TcM a) -> SrcSpan -> ForeignHValue {- TH.Q a -} -> TcM b runQResult show_th f runQ expr_span hval = do { th_result <- runQ hval + ; th_origin <- getThSpliceOrigin ; traceTc "Got TH result:" (text (show_th th_result)) - ; return (f expr_span th_result) } + ; return (f th_origin expr_span th_result) } ----------------- @@ -972,7 +1006,8 @@ instance TH.Quasi TcM where qAddTopDecls thds = do l <- getSrcSpanM - let either_hval = convertToHsDecls l thds + th_origin <- getThSpliceOrigin + let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of Left exn -> failWithTc $ hang (text "Error in a declaration passed to addTopDecls:") @@ -1255,7 +1290,8 @@ reifyInstances th_nm th_tys = addErrCtxt (text "In the argument of reifyInstances:" <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ do { loc <- getSrcSpanM - ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys) + ; th_origin <- getThSpliceOrigin + ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) -- #9262 says to bring vars into scope, like in HsForAllTy case -- of rnHsTyKi ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty @@ -1297,10 +1333,10 @@ reifyInstances th_nm th_tys doc = ClassInstanceCtx bale_out msg = failWithTc msg - cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs) - cvt loc th_ty = case convertToHsType loc th_ty of - Left msg -> failWithTc msg - Right ty -> return ty + cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) + cvt origin loc th_ty = case convertToHsType origin loc th_ty of + Left msg -> failWithTc msg + Right ty -> return ty {- ************************************************************************ diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 9a81e35e06..545f001f00 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -454,9 +454,9 @@ We do the following steps: B :-> TcTyCon <initial kind> (thereby overriding the B :-> TyConPE binding) and do kcLTyClDecl on each decl to get equality constraints on - all those inital kinds + all those initial kinds - - Generalise the inital kind, making a poly-kinded TcTyCon + - Generalise the initial kind, making a poly-kinded TcTyCon 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded TcTyCons, again overriding the promotion-error bindings. @@ -997,15 +997,15 @@ mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) = unitNameEnv nm (APromotionErr ClassPE) `plusNameEnv` mkNameEnv [ (name, APromotionErr TyConPE) - | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ] + | (L _ (FamilyDecl { fdLName = L _ name })) <- ats ] -mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name) +mk_prom_err_env (DataDecl { tcdLName = L _ name , tcdDataDefn = HsDataDefn { dd_cons = cons } }) = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` mkNameEnv [ (con, APromotionErr RecDataConPE) - | (dL->L _ con') <- cons - , (dL->L _ con) <- getConNames con' ] + | L _ con' <- cons + , L _ con <- getConNames con' ] mk_prom_err_env decl = unitNameEnv (tcdName decl) (APromotionErr TyConPE) @@ -1054,7 +1054,7 @@ getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] -- -- No family instances are passed to checkInitialKinds/inferInitialKinds getInitialKind strategy - (ClassDecl { tcdLName = dL->L _ name + (ClassDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdATs = ats }) = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ @@ -1072,7 +1072,7 @@ getInitialKind strategy InitialKindCheck _ -> check_initial_kind_assoc_fam cls getInitialKind strategy - (DataDecl { tcdLName = dL->L _ name + (DataDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_ND = new_or_data } }) @@ -1105,7 +1105,7 @@ getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = ; return [tc] } getInitialKind strategy - (SynDecl { tcdLName = dL->L _ name + (SynDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdRhs = rhs }) = do { let ctxt = TySynKindCtxt name @@ -1124,14 +1124,14 @@ get_fam_decl_initial_kind -> FamilyDecl GhcRn -> TcM TcTyCon get_fam_decl_initial_kind mb_parent_tycon - FamilyDecl { fdLName = (dL->L _ name) + FamilyDecl { fdLName = L _ name , fdTyVars = ktvs - , fdResultSig = (dL->L _ resultSig) + , fdResultSig = L _ resultSig , fdInfo = info } = kcDeclHeader InitialKindInfer name flav ktvs $ case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) -- closed type families have their return kind inferred @@ -1258,7 +1258,7 @@ Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] -kcLTyClDecl (dL->L loc decl) +kcLTyClDecl (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ do { traceTc "kcTyClDecl {" (ppr tc_name) @@ -1273,10 +1273,10 @@ kcTyClDecl :: TyClDecl GhcRn -> TcM () -- result kind signature have already been dealt with -- by inferInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) +kcTyClDecl (DataDecl { tcdLName = (L _ name) , tcdDataDefn = defn }) - | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _) - , dd_ctxt = (dL->L _ []) + | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _) + , dd_ctxt = (L _ []) , dd_ND = new_or_data } <- defn = do { tyCon <- kcLookupTcTyCon name -- See Note [Implementation of UnliftedNewtypes] STEP 2 @@ -1298,13 +1298,13 @@ kcTyClDecl (DataDecl { tcdLName = (dL->L _ name) ; kcConDecls new_or_data (tyConResKind tyCon) cons } -kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs }) +kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) = bindTyClTyVars name $ \ _ res_kind -> discardResult $ tcCheckLHsType rhs res_kind -- NB: check against the result kind that we allocated -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) +kcTyClDecl (ClassDecl { tcdLName = L _ name , tcdCtxt = ctxt, tcdSigs = sigs }) = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt @@ -1315,7 +1315,7 @@ kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name) skol_info = TyConSkol ClassFlavour name -kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name) +kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = L _ fam_tc_name , fdInfo = fd_info })) -- closed type families look at their equations, but other families don't -- do anything here @@ -1692,13 +1692,13 @@ There's also a change in the renamer: inside the data constructor to determine the result kind. See Note [Unlifted Newtypes and CUSKs] for more detail. -For completeness, it was also neccessary to make coerce work on +For completeness, it was also necessary to make coerce work on unlifted types, resolving #13595. -} tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl roles_info (dL->L loc decl) +tcTyClDecl roles_info (L loc decl) | Just thing <- wiredInNameTyThing_maybe (tcdName decl) = case thing of -- See Note [Declarations for wired-in things] ATyCon tc -> return (tc, wiredInDerivInfo tc decl) @@ -1735,7 +1735,7 @@ tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) -- "type" synonym declaration tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = (dL->L _ tc_name) + (SynDecl { tcdLName = L _ tc_name , tcdRhs = rhs }) = ASSERT( isNothing _parent ) fmap noDerivInfos $ @@ -1744,7 +1744,7 @@ tcTyClDecl1 _parent roles_info -- "data/newtype" declaration tcTyClDecl1 _parent roles_info - decl@(DataDecl { tcdLName = (dL->L _ tc_name) + decl@(DataDecl { tcdLName = L _ tc_name , tcdDataDefn = defn }) = ASSERT( isNothing _parent ) bindTyClTyVars tc_name $ \ tycon_binders res_kind -> @@ -1752,7 +1752,7 @@ tcTyClDecl1 _parent roles_info tycon_binders res_kind defn tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = (dL->L _ class_name) + (ClassDecl { tcdLName = L _ class_name , tcdCtxt = hs_ctxt , tcdMeths = meths , tcdFDs = fundeps @@ -1853,10 +1853,10 @@ tcClassATs class_name cls ats at_defs ; mapM tc_at ats } where at_def_tycon :: LTyFamDefltDecl GhcRn -> Name - at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn + at_def_tycon (L _ eqn) = tyFamInstDeclName eqn at_fam_name :: LFamilyDecl GhcRn -> Name - at_fam_name (dL->L _ decl) = unLoc (fdLName decl) + at_fam_name (L _ decl) = unLoc (fdLName decl) at_names = mkNameSet (map at_fam_name ats) @@ -1885,7 +1885,7 @@ tcDefaultAssocDecl _ (d1:_:_) <+> ppr (tyFamInstDeclName (unLoc d1))) tcDefaultAssocDecl fam_tc - [dL->L loc (TyFamInstDecl { tfid_eqn = + [L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ tc_name , feqn_bndrs = mb_expl_bndrs @@ -1983,8 +1983,9 @@ tcDefaultAssocDecl fam_tc suggestion :: SDoc suggestion = text "The arguments to" <+> quotes (ppr fam_tc) <+> text "must all be distinct type variables" -tcDefaultAssocDecl _ [_] - = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884 + +tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x +tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x {- Note [Type-checking default assoc decls] @@ -2052,8 +2053,8 @@ delicate for my taste, but it works. tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info - , fdLName = tc_lname@(dL->L _ tc_name) - , fdResultSig = (dL->L _ sig) + , fdLName = tc_lname@(L _ tc_name) + , fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info = bindTyClTyVars tc_name $ \ binders res_kind -> do @@ -2176,7 +2177,7 @@ tcInjectivity _ Nothing -- therefore we can always infer the result kind if we know the result type. -- But this does not seem to be useful in any way so we don't do it. (Another -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames))) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) = setSrcSpan loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags @@ -2300,11 +2301,11 @@ kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () -- Used for the equations of a closed type family only -- Not used for data/type instances kcTyFamInstEqn tc_fam_tc - (dL->L loc (HsIB { hsib_ext = imp_vars - , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name - , feqn_bndrs = mb_expl_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})) + (L loc (HsIB { hsib_ext = imp_vars + , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = mb_expl_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty }})) = setSrcSpan loc $ do { traceTc "kcTyFamInstEqn" (vcat [ text "tc_name =" <+> ppr eqn_tc_name @@ -2330,9 +2331,8 @@ kcTyFamInstEqn tc_fam_tc where vis_arity = length (tyConVisibleTyVars tc_fam_tc) -kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs nec)) = noExtCon nec -kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn nec))) = noExtCon nec -kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884 +kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec +kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec -------------------------- @@ -2342,7 +2342,7 @@ tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo - (dL->L loc (HsIB { hsib_ext = imp_vars + (L loc (HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name , feqn_bndrs = mb_expl_bndrs , feqn_pats = hs_pats @@ -2642,8 +2642,8 @@ dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons ----------------------------------- consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True -consUseGadtSyntax _ = False +consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True +consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- @@ -2734,7 +2734,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data -- the universals followed by the existentials. -- See Note [DataCon user type variable binders] in DataCon. user_tvbs = univ_tvbs ++ ex_tvbs - buildOneDataCon (dL->L _ name) = do + buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixH98 name hs_args ; rep_nm <- newTyConRepName name @@ -2762,7 +2762,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) - ; let ((dL->L _ name) : _) = names + ; let (L _ name : _) = names ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushTcLevelM_ $ -- We are going to generalise @@ -2821,7 +2821,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let - buildOneDataCon (dL->L _ name) = do + buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixGADT name hs_args ; rep_nm <- newTyConRepName name @@ -2875,7 +2875,7 @@ tcConArgs (RecCon fields) = mapM tcConArg btys where -- We need a one-to-one mapping from field_names to btys - combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f)) + combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined @@ -3546,12 +3546,12 @@ checkValidDataCon dflags existential_ok tc con user_tvbs_invariant = Set.fromList (filterEqSpec eq_spec univs ++ exs) == Set.fromList user_tvs - ; WARN( not user_tvbs_invariant + ; MASSERT2( user_tvbs_invariant , vcat ([ ppr con , ppr univs , ppr exs , ppr eq_spec - , ppr user_tvs ])) return () } + , ppr user_tvs ])) } ; traceTc "Done validity of data con" $ vcat [ ppr con @@ -4040,7 +4040,7 @@ checkValidRoleAnnots role_annots tc check_roles = whenIsJust role_annot_decl_maybe $ - \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) -> + \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ setSrcSpan loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations @@ -4064,11 +4064,10 @@ checkValidRoleAnnots role_annots tc = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (dL->L _ Nothing) _ = return () -checkRoleAnnot tv (dL->L _ (Just r1)) r2 +checkRoleAnnot _ (L _ Nothing) _ = return () +checkRoleAnnot tv (L _ (Just r1)) r2 = when (r1 /= r2) $ addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 -checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884 -- This is a double-check on the role inference algorithm. It is only run when -- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls @@ -4355,25 +4354,21 @@ badRoleAnnot var annot inferred , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc -wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots)) +wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) = hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) 2 (ppr d) -wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec -wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match" - -- due to #15884 +wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _)) +illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") -illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec -illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match" - -- due to #15884 +illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 026186c1bd..c7bcfbe068 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -225,7 +225,7 @@ checkSynCycles this_uid tcs tyclds = do mod = nameModule n ppr_decl tc = case lookupNameEnv lcl_decls n of - Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl + Just (L loc decl) -> ppr loc <> colon <+> ppr decl Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" where @@ -486,7 +486,7 @@ initialRoleEnv1 hsc_src annots_env tc -- is wrong, just ignore it. We check this in the validity check. role_annots = case lookupRoleAnnot annots_env name of - Just (dL->L _ (RoleAnnotDecl _ _ annots)) + Just (L _ (RoleAnnotDecl _ _ annots)) | annots `lengthIs` num_exps -> map unLoc annots _ -> replicate num_exps Nothing default_roles = build_default_roles argflags role_annots @@ -828,13 +828,13 @@ when typechecking the [d| .. |] quote, and typecheck them later. tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $ + = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ cL loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs - , let loc = getSrcSpan sel_id ] + sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs + , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)] @@ -854,7 +854,7 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl - = (sel_id, cL loc sel_bind) + = (sel_id, L loc sel_bind) where loc = getSrcSpan sel_name lbl = flLabel fl @@ -892,18 +892,18 @@ mkOneRecordSelector all_cons idDetails fl [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [cL loc (mk_sel_pat con)] - (cL loc (HsVar noExtField (cL loc field_var))) - mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields) + [L loc (mk_sel_pat con)] + (L loc (HsVar noExtField (L loc field_var))) + mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField { hsRecFieldLbl - = cL loc (FieldOcc sel_name - (cL loc $ mkVarUnqual lbl)) + = L loc (FieldOcc sel_name + (L loc $ mkVarUnqual lbl)) , hsRecFieldArg - = cL loc (VarPat noExtField (cL loc field_var)) + = L loc (VarPat noExtField (L loc field_var)) , hsRecPun = False }) - sel_lname = cL loc sel_name + sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive @@ -911,10 +911,10 @@ mkOneRecordSelector all_cons idDetails fl -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [cL loc (WildPat noExtField)] - (mkHsApp (cL loc (HsVar noExtField - (cL loc (getName rEC_SEL_ERROR_ID)))) - (cL loc (HsLit noExtField msg_lit)))] + [L loc (WildPat noExtField)] + (mkHsApp (L loc (HsVar noExtField + (L loc (getName rEC_SEL_ERROR_ID)))) + (L loc (HsLit noExtField msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 1537859d1b..90680f093f 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -277,7 +277,7 @@ Note, though, that a /bound/ type variable can (and probably should) be a TyVar. E.g forall a. a -> a Here 'a' is really just a deBruijn-number; it certainly does not have -a signficant TcLevel (as every TcTyVar does). So a forall-bound type +a significant TcLevel (as every TcTyVar does). So a forall-bound type variable should be TyVars; and hence a TyVar can appear free in a TcType. The type checker and constraint solver can also encounter /free/ type @@ -1657,7 +1657,7 @@ pickQuantifiablePreds qtvs theta EqPred eq_rel ty1 ty2 | quantify_equality eq_rel ty1 ty2 , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 - -- boxEqPred: See Note [Lift equality constaints when quantifying] + -- boxEqPred: See Note [Lift equality constraints when quantifying] , pick_cls_pred flex_ctxt cls tys -> Just (mkClassPred cls tys) @@ -1875,7 +1875,7 @@ Notice that See also TcTyDecls.checkClassCycles. -Note [Lift equality constaints when quantifying] +Note [Lift equality constraints when quantifying] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't quantify over a constraint (t1 ~# t2) because that isn't a predicate type; see Note [Types for coercions, predicates, and evidence] diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 44842e43ae..9f9e69850d 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -1715,7 +1715,7 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2 = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) -- Occurs check or an untouchable: just defer -- NB: occurs check isn't necessarily fatal: - -- eg tv1 occured in type family parameter + -- eg tv1 occurred in type family parameter ; defer } ty1 = mkTyVarTy tv1 diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index f02cb887cf..3f780fe546 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -2574,7 +2574,7 @@ Notice that: positions where the class header has no influence over the parameter. Hence the fancy footwork in pp_expected_ty - - Although the binders in the axiom are aready tidy, we must + - Although the binders in the axiom are already tidy, we must re-tidy them to get a fresh variable name when we shadow - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index b99983f779..47868ad9a1 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -2856,7 +2856,7 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs "simplifyArgsWorker wandered into deeper water than usual" -- This debug information is commented out because leaving it in -- causes a ~2% increase in allocations in T9872d. - -- That's independent of the analagous case in flatten_args_fast + -- That's independent of the analogous case in flatten_args_fast -- in TcFlatten: -- each of these causes a 2% increase on its own, so commenting them -- both out gives a 4% decrease in T9872d. diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index c0b6414f8c..168cc0fc40 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -50,7 +50,6 @@ import CoAxiom import VarSet import VarEnv import Name -import PrelNames ( eqPrimTyConKey ) import UniqDFM import Outputable import Maybes @@ -1253,7 +1252,7 @@ because type families are saturated. But if S has a type family on its RHS we expand /before/ normalising the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them -after expansion, and that can lead to /exponential/ behavour; see #13035. +after expansion, and that can lead to /exponential/ behaviour; see #13035. Notice, though, that expanding first can in principle duplicate t1,t2, which might contain redexes. I'm sure you could conjure up an exponential @@ -1772,9 +1771,8 @@ coreFlattenCo :: TvSubstEnv -> FlattenEnv coreFlattenCo subst env co = (env2, mkCoVarCo covar) where - fresh_name = mkFlattenFreshCoName (env1, kind') = coreFlattenTy subst env (coercionType co) - covar = uniqAway (fe_in_scope env1) (mkCoVar fresh_name kind') + covar = mkFlattenFreshCoVar (fe_in_scope env1) kind' -- Add the covar to the FlattenEnv's in-scope set. -- See Note [Flattening], wrinkle 2A. env2 = updateInScopeSet env1 (flip extendInScopeSet covar) @@ -1827,6 +1825,8 @@ mkFlattenFreshTyName :: Uniquable a => a -> Name mkFlattenFreshTyName unq = mkSysTvName (getUnique unq) (fsLit "flt") -mkFlattenFreshCoName :: Name -mkFlattenFreshCoName - = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc") +mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar +mkFlattenFreshCoVar in_scope kind + = let uniq = unsafeGetFreshLocalUnique in_scope + name = mkSystemVarName uniq (fsLit "flc") + in mkCoVar name kind diff --git a/compiler/types/TyCoFVs.hs b/compiler/types/TyCoFVs.hs index 19371df254..eefd68f145 100644 --- a/compiler/types/TyCoFVs.hs +++ b/compiler/types/TyCoFVs.hs @@ -70,7 +70,7 @@ so we profiled several versions, exploring different implementation strategies. tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty This is not nice, because FV introduces some overhead to implement - determinism, and throught its "interesting var" function, neither of which + determinism, and through its "interesting var" function, neither of which we need here, so they are a complete waste. 2. UnionVarSet version: instead of reusing the FV-based code, we simply used diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index 63f024a824..0e41ca66ac 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -922,7 +922,7 @@ we invoke Although we have unified k and j, it's very important that we put (Refl j), /not/ (Refl k) as the fourth argument to unify_tys. -If we put (Refl k) we'd end up with teh substitution +If we put (Refl k) we'd end up with the substitution a :-> b |> Refl k which is bogus because one of the template variables, k, appears in the range of the substitution. Eek. diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 05a7deb0ef..51d7db1fdf 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -394,7 +394,7 @@ The new scheme also does not depend in any way on architecture specific details. We still use this scheme even with LEB128 available, -as it has less overhead for truely large numbers. (> maxBound :: Int64) +as it has less overhead for truly large numbers. (> maxBound :: Int64) The instance is used for in Binary Integer and Binary Rational in basicTypes/Literal.hs -} diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs index cb401be274..c205c45d8d 100644 --- a/compiler/utils/Digraph.hs +++ b/compiler/utils/Digraph.hs @@ -158,7 +158,7 @@ type ReduceFn key payload = Note [reduceNodesIntoVertices implementations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ reduceNodesIntoVertices is parameterized by the container type. -This is to accomodate key types that don't have an Ord instance +This is to accommodate key types that don't have an Ord instance and hence preclude the use of Data.Map. An example of such type would be Unique, there's no way to implement Ord Unique deterministically. diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index bb4504ff1f..0a7981b0c8 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -264,8 +264,8 @@ delCoalesce k1 k2 -- | Add a color preference to the graph, creating nodes if required. --- The most recently added preference is the most prefered. --- The algorithm tries to assign a node it's prefered color if possible. +-- The most recently added preference is the most preferred. +-- The algorithm tries to assign a node it's preferred color if possible. -- addPreference :: Uniquable k diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index cd3e2a5f5b..bbc365b774 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -1239,7 +1239,7 @@ warnPprTrace True file line msg x where heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] --- | Panic with an assertation failure, recording the given file and +-- | Panic with an assertion failure, recording the given file and -- line number. Should typically be accessed with the ASSERT family of macros assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a assertPprPanic _file _line msg diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs index 1b104a66cd..f9588e9b0b 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs @@ -397,7 +397,7 @@ instance Monoid (UniqDFM a) where mempty = emptyUDFM mappend = (Semi.<>) --- This should not be used in commited code, provided for convenience to +-- This should not be used in committed code, provided for convenience to -- make ad-hoc conversions when developing alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList diff --git a/configure.ac b/configure.ac index 59541f002f..8d6ceb9e65 100644 --- a/configure.ac +++ b/configure.ac @@ -465,7 +465,7 @@ dnl ** Building a cross compiler? dnl -------------------------------------------------------------- CrossCompiling=NO # If 'host' and 'target' differ, then this means we are building a cross-compiler. -if test "$TargetPlatform" != "$HostPlatform" ; then +if test "$target" != "$host" ; then CrossCompiling=YES cross_compiling=yes # This tells configure that it can accept just 'target', # otherwise you get @@ -715,7 +715,9 @@ FP_GCC_SUPPORTS_NO_PIE dnl ** Used to determine how to compile ghc-prim's atomics.c, used by dnl unregisterised, Sparc, and PPC backends. FP_GCC_SUPPORTS__ATOMICS -AC_DEFINE([HAVE_C11_ATOMICS], [$CONF_GCC_SUPPORTS__ATOMICS], [Does GCC support __atomic primitives?]) +if test $CONF_GCC_SUPPORTS__ATOMICS = YES ; then + AC_DEFINE([HAVE_C11_ATOMICS], [1], [Does GCC support __atomic primitives?]) +fi FP_GCC_EXTRA_FLAGS diff --git a/docs/coding-style.html b/docs/coding-style.html index dbf0f8729a..c94913eac8 100644 --- a/docs/coding-style.html +++ b/docs/coding-style.html @@ -332,7 +332,7 @@ can be "polymorphic" as these examples show: Inline functions should be "static inline" because: <ul> <li> -gcc will delete static inlines if not used or theyre always inlined. +gcc will delete static inlines if not used or they're always inlined. <li> if they're externed, we could get conflicts between 2 copies of the diff --git a/docs/core-spec/core-spec.mng b/docs/core-spec/core-spec.mng index 5fdf3af027..3afec2bbb7 100644 --- a/docs/core-spec/core-spec.mng +++ b/docs/core-spec/core-spec.mng @@ -121,7 +121,7 @@ to be built with \texttt{CoercionTy}. laid out in \verb|Note [Invariants on join points]| in \ghcfile{coreSyn/CoreSyn.hs}: \begin{enumerate} - \item All occurences must be tail calls. This is enforced in our typing + \item All occurrences must be tail calls. This is enforced in our typing rules using the label environment $[[D]]$. \item Each join point has a \emph{join arity}. In this document, we write each label as $[[p/I_t]]$ for the name $[[p]]$, the type $[[t]]$, and the diff --git a/docs/opt-coercion/code.sty b/docs/opt-coercion/code.sty index fe5b38c35c..e5abaaf424 100644 --- a/docs/opt-coercion/code.sty +++ b/docs/opt-coercion/code.sty @@ -4,22 +4,22 @@ % you write "\makeatactive". From then on, inline code is written as @\x % -> x_1 & y@. The only difference with what you are used to, is that % instead of -% +% % @ % foo :: Int -> Int % foo = \n -> n+1 % @ -% +% % you have to write -% +% % \begin{code} % foo :: Int -> Int % foo = \n -> n+1 % \end{code} -% -% and that you cannot use @ in \section{} and \caption{}. For the paper that occured twice, in which case I had to replace @...@ b y \texttt{...}. -% -% +% +% and that you cannot use @ in \section{} and \caption{}. For the paper that occurred twice, in which case I had to replace @...@ b y \texttt{...}. +% +% % code.sty --- nice verbatim mode for code % To get '@' use \verb+@+ diff --git a/docs/opt-coercion/fc-normalization-rta.tex b/docs/opt-coercion/fc-normalization-rta.tex index a1e7d4201d..0600427e98 100755 --- a/docs/opt-coercion/fc-normalization-rta.tex +++ b/docs/opt-coercion/fc-normalization-rta.tex @@ -227,7 +227,7 @@ which has evolved from System F to System FC source-language features of \emph{GADTs}~\cite{cheney-hinze:phantom-types,sheard:omega,spj+:gadt} and \emph{type families}~\cite{Kiselyov09funwith,chak+:synonyms}. -The key feature that allows System FC to accomodate GADTs and type +The key feature that allows System FC to accommodate GADTs and type families is its use of explicit \emph{coercions} that witness the equality of two syntactically-different types. Coercions are erased before runtime but, like types, serve as a static consistency @@ -802,7 +802,7 @@ $$ \gamma ; \sym{\gamma} & \rsa{} & \refl{\tau} & \text{if}\,\gamma : \tau \psim \phi \end{array} $$ -But ther are much more complicated rewrites to consider. +But there are much more complicated rewrites to consider. Consider these coercions, where $C_N$ is the axiom generated by the newtype coercion in Section~\ref{sec:newtype}: $$ diff --git a/docs/rts/rts.tex b/docs/rts/rts.tex index bd54824707..d5d4f6d67d 100644 --- a/docs/rts/rts.tex +++ b/docs/rts/rts.tex @@ -640,7 +640,7 @@ only requires one argument so it leaves the second argument as a until @f@ calls @g@ which requires two arguments: the argument passed to it by @f@ and the pending argument which was passed to @f@. -Unboxed pending arguments are always preceeded by a ``tag'' which says +Unboxed pending arguments are always preceded by a ``tag'' which says how large the argument is. This allows the garbage collector to locate pointers within the stack. @@ -3250,7 +3250,7 @@ entered a @AP@ by switching worlds, entering the @AP@, pushing the arguments and function onto the stack, and entering the function which, likely as not, will be a byte-code object which we will enter by \emph{returning} to the byte-code interpreter. To avoid such -gratuitious world switching, we choose to recognise certain closure +gratuitous world switching, we choose to recognise certain closure types as being ``standard'' --- and duplicate the entry code for the ``standard closures'' in the bytecode interpreter. diff --git a/docs/stg-spec/stg-spec.mng b/docs/stg-spec/stg-spec.mng index 7e87c151d9..ea1b16746c 100644 --- a/docs/stg-spec/stg-spec.mng +++ b/docs/stg-spec/stg-spec.mng @@ -131,7 +131,7 @@ acts as a pointer to the value on the heap. \gram{\ottheap} -Execution procedes until a return value (a literal or a variable, i.e. +Execution proceeds until a return value (a literal or a variable, i.e. pointer to the heap) is produced. To accommodate for let-no-escape bindings, we also allow execution to terminate with a jump to a function application of a let-no-escape variable. diff --git a/docs/storage-mgt/code.sty b/docs/storage-mgt/code.sty index f5ec2f59ee..175e212653 100644 --- a/docs/storage-mgt/code.sty +++ b/docs/storage-mgt/code.sty @@ -4,22 +4,22 @@ % you write "\makeatactive". From then on, inline code is written as @\x
% -> x_1 & y@. The only difference with what you are used to, is that
% instead of
-%
+%
% @
% foo :: Int -> Int
% foo = \n -> n+1
% @
-%
+%
% you have to write
-%
+%
% \begin{code}
% foo :: Int -> Int
% foo = \n -> n+1
% \end{code}
-%
-% and that you cannot use @ in \section{} and \caption{}. For the paper that occured twice, in which case I had to replace @...@ b y \texttt{...}.
-%
-%
+%
+% and that you cannot use @ in \section{} and \caption{}. For the paper that occurred twice, in which case I had to replace @...@ b y \texttt{...}.
+%
+%
% code.sty --- nice verbatim mode for code
\def\icode{%
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst index e5ed23ca3e..4e9a9fc613 100644 --- a/docs/users_guide/8.10.1-notes.rst +++ b/docs/users_guide/8.10.1-notes.rst @@ -152,7 +152,7 @@ Language Because GHC needs to look under a type family to see that ``a`` is determined by the right-hand side of ``F2``\'s equation, this now needs ``-XUndecidableInstances``. The problem is very much akin to its need to detect some functional dependencies. - + Compiler ~~~~~~~~ @@ -203,6 +203,9 @@ Compiler and much more. See the :ref:`user guide <dynflags_plugins>` for more details as well as an example. +- Deprecated flag :ghc-flag:`-fmax-pmcheck-iterations` in favor of + :ghc-flag:`-fmax-pmcheck-models`, which uses a completely different mechanism. + GHCi ~~~~ @@ -274,6 +277,14 @@ Template Haskell tStr :: String tStr = show MkT +- TH splices by default don't generate warnings anymore. For example, + ``$([d| f :: Int -> void; f x = case x of {} |])`` used to generate a + pattern-match exhaustivity warning, which now it doesn't. The user can + activate warnings for TH splices with :ghc-flag:`-fenable-th-splice-warnings`. + The reason for opt-in is that the offending code might not have been generated + by code the user has control over, for example the ``singletons`` or ``lens`` + library. + ``ghc-prim`` library ~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst new file mode 100644 index 0000000000..94979e80c4 --- /dev/null +++ b/docs/users_guide/8.12.1-notes.rst @@ -0,0 +1,98 @@ +.. _release-8-12-1: + +Release notes for version 8.12.1 +================================ + +The significant changes to the various parts of the compiler are listed in the +following sections. + + +Highlights +---------- + +- TODO + +Full details +------------ + +Language +~~~~~~~~ + +Compiler +~~~~~~~~ + + +GHCi +~~~~ + + +Runtime system +~~~~~~~~~~~~~~ + +Template Haskell +~~~~~~~~~~~~~~~~ + +``ghc-prim`` library +~~~~~~~~~~~~~~~~~~~~ + +``ghc`` library +~~~~~~~~~~~~~~~ + + - The type of the ``getAnnotations`` function has changed to better reflect + the fact that it returns two different kinds of annotations, those on + names and those on modules: :: + + getAnnotations :: Typeable a + => ([Word8] -> a) -> ModGuts + -> CoreM (ModuleEnv [a], NameEnv [a]) + + +``base`` library +~~~~~~~~~~~~~~~~ + +Build system +~~~~~~~~~~~~ + +Included libraries +------------------ + +The package database provided with this distribution also contains a number of +packages other than GHC itself. See the changelogs provided with these packages +for further change information. + +.. ghc-package-list:: + + libraries/array/array.cabal: Dependency of ``ghc`` library + libraries/base/base.cabal: Core library + libraries/binary/binary.cabal: Dependency of ``ghc`` library + libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library + libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility + libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library + libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library + libraries/directory/directory.cabal: Dependency of ``ghc`` library + libraries/filepath/filepath.cabal: Dependency of ``ghc`` library + compiler/ghc.cabal: The compiler itself + libraries/ghci/ghci.cabal: The REPL interface + libraries/ghc-boot/ghc-boot.cabal: Internal compiler library + libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library + libraries/ghc-compact/ghc-compact.cabal: Core library + libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library + libraries/ghc-prim/ghc-prim.cabal: Core library + libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable + libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable + libraries/integer-gmp/integer-gmp.cabal: Core library + libraries/libiserv/libiserv.cabal: Internal compiler library + libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library + libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library + libraries/pretty/pretty.cabal: Dependency of ``ghc`` library + libraries/process/process.cabal: Dependency of ``ghc`` library + libraries/stm/stm.cabal: Dependency of ``haskeline`` library + libraries/template-haskell/template-haskell.cabal: Core library + libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library + libraries/text/text.cabal: Dependency of ``Cabal`` library + libraries/time/time.cabal: Dependency of ``ghc`` library + libraries/transformers/transformers.cabal: Dependency of ``ghc`` library + libraries/unix/unix.cabal: Dependency of ``ghc`` library + libraries/Win32/Win32.cabal: Dependency of ``ghc`` library + libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable + diff --git a/docs/users_guide/bugs.rst b/docs/users_guide/bugs.rst index c0cffa0ee8..4dc49f0328 100644 --- a/docs/users_guide/bugs.rst +++ b/docs/users_guide/bugs.rst @@ -49,6 +49,45 @@ Lexical syntax reserving ``forall`` as a keyword has significance. For instance, GHC will not parse the type signature ``foo :: forall x``. +- The ``(!)`` operator, when written in prefix form (preceded by whitespace + and not followed by whitespace, as in ``f !x = ...``), is interpreted as a + bang pattern, contrary to the Haskell Report, which prescribes to treat ``!`` + as an operator regardless of surrounding whitespace. Note that this does not + imply that GHC always enables :extension:`BangPatterns`. Without the + extension, GHC will issue a parse error on ``f !x``, asking to enable the + extension. + +- Irrefutable patterns must be written in prefix form:: + + f ~a ~b = ... -- accepted by both GHC and the Haskell Report + f ~ a ~ b = ... -- accepted by the Haskell Report but not GHC + + When written in non-prefix form, ``(~)`` is treated by GHC as a regular + infix operator. + + See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__ + for the precise rules. + +- Strictness annotations in data declarations must be written in prefix form:: + + data T = MkT !Int -- accepted by both GHC and the Haskell Report + data T = MkT ! Int -- accepted by the Haskell Report but not GHC + + See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__ + for the precise rules. + +- As-patterns must not be surrounded by whitespace:: + + f p@(x, y, z) = ... -- accepted by both GHC and the Haskell Report + f p @ (x, y, z) = ... -- accepted by the Haskell Report but not GHC + + When surrounded by whitespace, ``(@)`` is treated by GHC as a regular infix + operator. + + See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__ + for the precise rules. + + .. _infelicities-syntax: Context-free syntax diff --git a/docs/users_guide/debug-info.rst b/docs/users_guide/debug-info.rst index 25491f7e43..45792c65df 100644 --- a/docs/users_guide/debug-info.rst +++ b/docs/users_guide/debug-info.rst @@ -147,7 +147,7 @@ this point in the program, For this reason we should be cautious when interpreting the source locations provided by GDB. While these locations will usually be in some sense - "correct", they aren't always useful. This is why profiling tools targetting + "correct", they aren't always useful. This is why profiling tools targeting Haskell should supplement the standard source location information with GHC-specific annotations (emitted with ``-g2``) when assigning costs. diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst index d1229ed0d5..35a49766b4 100644 --- a/docs/users_guide/ghci.rst +++ b/docs/users_guide/ghci.rst @@ -2121,7 +2121,7 @@ On systems with ``.dll``-style shared libraries, the actual library loaded will be ``lib.dll``, ``liblib.dll``. GHCi also has full support for import libraries, either Microsoft style ``.lib``, or GNU GCC style ``.a`` and ``.dll.a`` libraries. If you have an import library it is advisable to always -specify the import libary instead of the ``.dll``. e.g. use ``-lgcc` instead of +specify the import library instead of the ``.dll``. e.g. use ``-lgcc` instead of ``-llibgcc_s_seh-1``. Again, GHCi will signal an error if it can't find the library. @@ -2387,7 +2387,7 @@ commonly used commands. Attempting to redefine an existing command name results in an error unless the ``:def!`` form is used, in which case the old command with that name is silently overwritten. However for builtin commands - the old command can still be used by preceeding the command name with + the old command can still be used by preceding the command name with a double colon (eg ``::load``). It's not possible to redefine the commands ``:{``, ``:}`` and ``:!``. diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index ec015aa673..7ba170845a 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -6956,7 +6956,7 @@ like this: client to deliberately override an instance from a library, without requiring a change to the library.) -- If all the remaining candidates are incoherent, the search suceeds, returning +- If all the remaining candidates are incoherent, the search succeeds, returning an arbitrary surviving candidate. - If more than one non-incoherent candidate remains, the search fails. @@ -8784,7 +8784,7 @@ injectivity of a type family: 5. In a *closed type family* all equations are ordered and in one place. Equations are also checked pair-wise but this time an equation has to - be paired with all the preceeding equations. Of course a + be paired with all the preceding equations. Of course a single-equation closed type family is trivially injective (unless (1), (2) or (3) above holds). @@ -13108,10 +13108,9 @@ enable the quotation subset of Template Haskell (i.e. without splice syntax). The :extension:`TemplateHaskellQuotes` extension is considered safe under :ref:`safe-haskell` while :extension:`TemplateHaskell` is not. -- A splice is written ``$x``, where ``x`` is an identifier, or - ``$(...)``, where the "..." is an arbitrary expression. There must be - no space between the "$" and the identifier or parenthesis. This use - of "$" overrides its meaning as an infix operator, just as "M.x" +- A splice is written ``$x``, where ``x`` is an arbitrary expression. + There must be no space between the "$" and the expression. + This use of "$" overrides its meaning as an infix operator, just as "M.x" overrides the meaning of "." as an infix operator. If you want the infix operator, put spaces around it. @@ -13147,9 +13146,8 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under See :ref:`pts-where` for using partial type signatures in quotations. -- A *typed* expression splice is written ``$$x``, where ``x`` is an - identifier, or ``$$(...)``, where the "..." is an arbitrary - expression. +- A *typed* expression splice is written ``$$x``, where ``x`` is + is an arbitrary expression. A typed expression splice can occur in place of an expression; the spliced expression must have type ``Q (TExp a)`` @@ -13404,6 +13402,17 @@ The syntax for a declaration splice uses "``$``" not "``splice``". The type of the enclosed expression must be ``Q [Dec]``, not ``[Q Dec]``. Typed expression splices and quotations are supported.) +.. ghc-flag:: -fenable-th-splice-warnings + :shortdesc: Generate warnings for Template Haskell splices + :type: dynamic + :reverse: -fno-enable-th-splices + :category: warnings + + Template Haskell splices won't be checked for warnings, because the code + causing the warning might originate from a third-party library and possibly + was not written by the user. If you want to have warnings for splices + anyway, pass :ghc-flag:`-fenable-th-splice-warnings`. + .. _th-usage: Using Template Haskell @@ -14312,12 +14321,15 @@ Note the following points: f !x = 3 - Is this a definition of the infix function "``(!)``", or of the "``f``" - with a bang pattern? GHC resolves this ambiguity in favour of the - latter. If you want to define ``(!)`` with bang-patterns enabled, you - have to do so using prefix notation: :: + Is this a definition of the infix function "``(!)``", or of the "``f``" with + a bang pattern? GHC resolves this ambiguity by looking at the surrounding + whitespace: :: - (!) f x = 3 + a ! b = ... -- infix operator + a !b = ... -- bang pattern + + See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__ + for the precise rules. .. _strict-data: @@ -14348,6 +14360,13 @@ we interpret it as if they had written :: The extension only affects definitions in this module. +The ``~`` annotation must be written in prefix form:: + + data T = MkT ~Int -- valid + data T = MkT ~ Int -- invalid + +See `GHC Proposal #229 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0229-whitespace-bang-patterns.rst>`__ +for the precise rules. .. _strict: @@ -14382,7 +14401,7 @@ optionally had by adding ``!`` in front of a variable. Adding ``~`` in front of ``x`` gives the regular lazy behavior. - Turning patterns into irrefutable ones requires ``~(~p)`` or ``(~ ~p)`` when ``Strict`` is enabled. + Turning patterns into irrefutable ones requires ``~(~p)`` when ``Strict`` is enabled. diff --git a/docs/users_guide/index.rst b/docs/users_guide/index.rst index e629af67a5..00e14409c4 100644 --- a/docs/users_guide/index.rst +++ b/docs/users_guide/index.rst @@ -14,6 +14,7 @@ Contents: intro 8.8.1-notes 8.10.1-notes + 8.12.1-notes ghci runghc usage diff --git a/docs/users_guide/runtime_control.rst b/docs/users_guide/runtime_control.rst index 1f4b766400..f6dd9a62e8 100644 --- a/docs/users_guide/runtime_control.rst +++ b/docs/users_guide/runtime_control.rst @@ -77,7 +77,8 @@ the end of the command line, as in this example: If you absolutely positively want all the rest of the options in a command line to go to the program (and not the RTS), use a -``--RTS``. +``--RTS`` or ``--``. The difference is that ``--RTS`` will not be passed to +the program, while ``--`` will. As always, for RTS options that take ⟨size⟩s: If the last character of ⟨size⟩ is a K or k, multiply by 1000; if an M or m, by 1,000,000; if a G diff --git a/docs/users_guide/safe_haskell.rst b/docs/users_guide/safe_haskell.rst index b95364531f..edfedda4b2 100644 --- a/docs/users_guide/safe_haskell.rst +++ b/docs/users_guide/safe_haskell.rst @@ -788,7 +788,7 @@ And five warning flags: .. index:: single: safe haskell imports, warning - The module ``A`` below is annotated to be explictly ``Safe``, but it imports + The module ``A`` below is annotated to be explicitly ``Safe``, but it imports ``Safe-Inferred`` module. :: {-# LANGUAGE Safe #-} diff --git a/docs/users_guide/separate_compilation.rst b/docs/users_guide/separate_compilation.rst index 716dd92223..11cd2cfc4e 100644 --- a/docs/users_guide/separate_compilation.rst +++ b/docs/users_guide/separate_compilation.rst @@ -597,7 +597,7 @@ The GHC API exposes functions for reading and writing these files. Runs a series of sanity checks and lints on the extended interface files that are being written out. These include testing things properties such as - variables not occuring outside of their expected scopes. + variables not occurring outside of their expected scopes. The format in which GHC currently stores its typechecked AST, makes it costly to collect the types for some expressions nodes. For the sake of performance, diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst index 62b644aa8a..4649f86de0 100644 --- a/docs/users_guide/using-warnings.rst +++ b/docs/users_guide/using-warnings.rst @@ -46,7 +46,6 @@ generally likely to indicate bugs in your program. These are: * :ghc-flag:`-Winaccessible-code` * :ghc-flag:`-Wstar-is-type` * :ghc-flag:`-Wstar-binder` - * :ghc-flag:`-Wspace-after-bang` The following flags are simple ways to select standard "packages" of warnings: @@ -1280,12 +1279,6 @@ of ``-W(no-)*``. per-module basis with :ghc-flag:`-Wno-simplifiable-class-constraints <-Wsimplifiable-class-constraints>`. -.. ghc-flag:: -Wspace-after-bang - :shortdesc: warn for missing space before the second argument - of an infix definition of ``(!)`` when - :extension:`BangPatterns` are not enabled - :type: dynamic - :reverse: -Wno-missing-space-after-bang .. ghc-flag:: -Wtabs :shortdesc: warn if there are tabs in the source file :type: dynamic diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index bf1eddfa5b..ba873d73ed 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1605,7 +1605,7 @@ editFile str = -- XXX: Can we figure out what happened if the depndecy analysis fails -- (e.g., because the porgrammeer mistyped the name of a module)? -- XXX: Can we figure out the location of an error to pass to the editor? --- XXX: if we could figure out the list of errors that occured during the +-- XXX: if we could figure out the list of errors that occurred during the -- last load/reaload, then we could start the editor focused on the first -- of those. chooseEditFile :: GHC.GhcMonad m => m String diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 2bf061f3b5..b07a376482 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -325,7 +325,7 @@ processAllTypeCheckedModule tcm = do -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) - getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) + getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid)) getTypeLHsBind _ = pure Nothing @@ -337,25 +337,25 @@ processAllTypeCheckedModule tcm = do return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe where mid :: Maybe Id - mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i - | otherwise = Nothing + mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i + | otherwise = Nothing unwrapVar (HsWrap _ _ var) = var unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) - getTypeLPat (dL->L spn pat) = + getTypeLPat (L spn pat) = pure (Just (getMaybeId pat,spn,hsPatType pat)) where - getMaybeId (VarPat _ (dL->L _ vid)) = Just vid + getMaybeId (VarPat _ (L _ vid)) = Just vid getMaybeId _ = Nothing -- | Get ALL source spans in the source. - listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a] + listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a] listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x])) where - p (dL->L spn _) = isGoodSrcSpan spn + p (L spn _) = isGoodSrcSpan spn -- | Variant of @syb@'s @everything@ (which summarises all nodes -- in top-down, left-to-right order) with a stop-condition on 'NameSet's diff --git a/hadrian/doc/flavours.md b/hadrian/doc/flavours.md index 6c05bd1478..61af4f4075 100644 --- a/hadrian/doc/flavours.md +++ b/hadrian/doc/flavours.md @@ -132,7 +132,7 @@ when compiling the `compiler` library, and `hsGhc` when compiling/linking the GH <td>-O</td> </tr> <tr> - <th>validate</td> + <th>slow-validate</td> <td>-O0<br>-H64m</td> <td>-fllvm-fill-undef-with-garbage</td> <td></td> diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal index 013896e887..8e8793fb1b 100644 --- a/hadrian/hadrian.cabal +++ b/hadrian/hadrian.cabal @@ -14,7 +14,7 @@ source-repository head type: git location: https://gitlab.haskell.org/ghc/ghc --- To accomodate #16873 +-- To accommodate #16873 flag threaded manual: True default: True diff --git a/hadrian/src/Context.hs b/hadrian/src/Context.hs index 0676743ee5..6e1d84de4b 100644 --- a/hadrian/src/Context.hs +++ b/hadrian/src/Context.hs @@ -51,7 +51,7 @@ libPath Context {..} = buildRoot <&> (-/- (stageString stage -/- "lib")) -- | Get the directory name for binary distribution files -- @<arch>-<os>-ghc-<version>@. -- --- We preform some renaming to accomodate Cabal's slightly different naming +-- We preform some renaming to accommodate Cabal's slightly different naming -- conventions (see 'cabalOsString' and 'cabalArchString'). distDir :: Stage -> Action FilePath distDir st = do diff --git a/hadrian/src/Hadrian/Builder.hs b/hadrian/src/Hadrian/Builder.hs index 5d645eea8c..fdfdb666ef 100644 --- a/hadrian/src/Hadrian/Builder.hs +++ b/hadrian/src/Hadrian/Builder.hs @@ -35,7 +35,7 @@ data BuildInfo = BuildInfo { buildOutputs :: [FilePath], -- | Options to be passed to Shake's 'cmd' function. buildOptions :: [CmdOption], - -- | Resources to be aquired. + -- | Resources to be acquired. buildResources :: [(Resource, Int)] } class ShakeValue b => Builder b where @@ -48,7 +48,7 @@ class ShakeValue b => Builder b where askBuilderWith :: b -> BuildInfo -> Action String -- | Runtime dependencies of a builder. For example, on Windows GHC requires - -- the utility @touchy.exe@ to be avilable on a specific path. + -- the utility @touchy.exe@ to be available on a specific path. runtimeDependencies :: b -> Action [FilePath] runtimeDependencies _ = return [] diff --git a/includes/HsFFI.h b/includes/HsFFI.h index 4b6278b518..32523b2c83 100644 --- a/includes/HsFFI.h +++ b/includes/HsFFI.h @@ -3,7 +3,7 @@ * (c) The GHC Team, 2000 * * A mapping for Haskell types to C types, including the corresponding bounds. - * Intended to be used in conjuction with the FFI. + * Intended to be used in conjunction with the FFI. * * WARNING: Keep this file and StgTypes.h in synch! * diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs index 8e285ac07c..a8dfa61115 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -194,7 +194,7 @@ immediate subterms. In the definition of gmapQr, extra effort is needed. We use a higher-order accumulation trick to mediate between left-associative constructor application vs. right-associative binary operation (e.g., @(:)@). When the query is meant to compute a value -of type @r@, then the result type withing generic folding is @r -> r@. +of type @r@, then the result type within generic folding is @r -> r@. So the result of folding is a function to which we finally pass the right unit. diff --git a/libraries/base/Data/IORef.hs b/libraries/base/Data/IORef.hs index 44769268cf..2886e594d3 100644 --- a/libraries/base/Data/IORef.hs +++ b/libraries/base/Data/IORef.hs @@ -49,7 +49,7 @@ mkWeakIORef r@(IORef (STRef r#)) (IO finalizer) = IO $ \s -> -- |Mutate the contents of an 'IORef'. -- -- Be warned that 'modifyIORef' does not apply the function strictly. This --- means if the program calls 'modifyIORef' many times, but seldomly uses the +-- means if the program calls 'modifyIORef' many times, but seldom uses the -- value, thunks will pile up in memory resulting in a space leak. This is a -- common mistake made when using an IORef as a counter. For example, the -- following will likely produce a stack overflow: diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs index 2bd0b1e00e..f646faeb9a 100644 --- a/libraries/base/Data/Maybe.hs +++ b/libraries/base/Data/Maybe.hs @@ -148,7 +148,7 @@ fromJust :: HasCallStack => Maybe a -> a fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck fromJust (Just x) = x --- | The 'fromMaybe' function takes a default value and and 'Maybe' +-- | The 'fromMaybe' function takes a default value and a 'Maybe' -- value. If the 'Maybe' is 'Nothing', it returns the default values; -- otherwise, it returns the value contained in the 'Maybe'. -- diff --git a/libraries/base/Data/STRef.hs b/libraries/base/Data/STRef.hs index 5b8c6b7901..3636e6a8a6 100644 --- a/libraries/base/Data/STRef.hs +++ b/libraries/base/Data/STRef.hs @@ -40,7 +40,7 @@ import GHC.STRef -- "Hello, world!" -- -- Be warned that 'modifySTRef' does not apply the function strictly. This --- means if the program calls 'modifySTRef' many times, but seldomly uses the +-- means if the program calls 'modifySTRef' many times, but seldom uses the -- value, thunks will pile up in memory resulting in a space leak. This is a -- common mistake made when using an 'STRef' as a counter. For example, the -- following will leak memory and may produce a stack overflow: diff --git a/libraries/base/Foreign/Marshal/Utils.hs b/libraries/base/Foreign/Marshal/Utils.hs index 30e80035fa..f6bec7aacb 100644 --- a/libraries/base/Foreign/Marshal/Utils.hs +++ b/libraries/base/Foreign/Marshal/Utils.hs @@ -6,7 +6,7 @@ -- Module : Foreign.Marshal.Utils -- Copyright : (c) The FFI task force 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : ffi@haskell.org -- Stability : provisional -- Portability : portable @@ -72,8 +72,8 @@ import GHC.Base -- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required. -- new :: Storable a => a -> IO (Ptr a) -new val = - do +new val = + do ptr <- malloc poke ptr val return ptr @@ -122,12 +122,12 @@ maybeNew = maybe (return nullPtr) -- |Converts a @withXXX@ combinator into one marshalling a value wrapped -- into a 'Maybe', using 'nullPtr' to represent 'Nothing'. -- -maybeWith :: ( a -> (Ptr b -> IO c) -> IO c) +maybeWith :: ( a -> (Ptr b -> IO c) -> IO c) -> (Maybe a -> (Ptr b -> IO c) -> IO c) maybeWith = maybe ($ nullPtr) -- |Convert a peek combinator into a one returning 'Nothing' if applied to a --- 'nullPtr' +-- 'nullPtr' -- maybePeek :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) maybePeek peek ptr | ptr == nullPtr = return Nothing @@ -155,16 +155,26 @@ withMany withFoo (x:xs) f = withFoo x $ \x' -> -- |Copies the given number of bytes from the second area (source) into the -- first (destination); the copied areas may /not/ overlap -- -copyBytes :: Ptr a -> Ptr a -> Int -> IO () -copyBytes dest src size = do _ <- memcpy dest src (fromIntegral size) - return () +copyBytes + :: Ptr a -- ^ Destination + -> Ptr a -- ^ Source + -> Int -- ^ Size in bytes + -> IO () +copyBytes dest src size = do + _ <- memcpy dest src (fromIntegral size) + return () -- |Copies the given number of bytes from the second area (source) into the -- first (destination); the copied areas /may/ overlap -- -moveBytes :: Ptr a -> Ptr a -> Int -> IO () -moveBytes dest src size = do _ <- memmove dest src (fromIntegral size) - return () +moveBytes + :: Ptr a -- ^ Destination + -> Ptr a -- ^ Source + -> Int -- ^ Size in bytes + -> IO () +moveBytes dest src size = do + _ <- memmove dest src (fromIntegral size) + return () -- Filling up memory area with required values -- ------------------------------------------- diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index a9d5410d9c..ad922d73f2 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -281,7 +281,7 @@ startIOManagerThread eventManagerArray i = do ThreadFinished -> create ThreadDied -> do -- Sanity check: if the thread has died, there is a chance - -- that event manager is still alive. This could happend during + -- that event manager is still alive. This could happened during -- the fork, for example. In this case we should clean up -- open pipes and everything else related to the event manager. -- See #4449 @@ -308,7 +308,7 @@ startTimerManagerThread = modifyMVar_ timerManagerThreadVar $ \old -> do ThreadFinished -> create ThreadDied -> do -- Sanity check: if the thread has died, there is a chance - -- that event manager is still alive. This could happend during + -- that event manager is still alive. This could happened during -- the fork, for example. In this case we should clean up -- open pipes and everything else related to the event manager. -- See #4449 diff --git a/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc b/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc index 1046fa9351..5e4e642009 100644 --- a/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc +++ b/libraries/base/GHC/IO/Handle/Lock/LinuxOFD.hsc @@ -12,8 +12,8 @@ module GHC.IO.Handle.Lock.LinuxOFD where import GHC.Base () -- Make implicit dependency known to build system #else -#include <sys/unistd.h> -#include <sys/fcntl.h> +#include <unistd.h> +#include <fcntl.h> import Data.Function import Data.Functor diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index 3185418d54..71bc3f0ce4 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -179,10 +179,10 @@ instance Bits Int8 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (I8# x#) .&. (I8# y#) = I8# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I8# x#) .|. (I8# y#) = I8# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I8# x#) = I8# (word2Int# (not# (int2Word# x#))) + (I8# x#) .&. (I8# y#) = I8# (x# `andI#` y#) + (I8# x#) .|. (I8# y#) = I8# (x# `orI#` y#) + (I8# x#) `xor` (I8# y#) = I8# (x# `xorI#` y#) + complement (I8# x#) = I8# (notI# x#) (I8# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I8# (narrow8Int# (x# `iShiftL#` i#)) | otherwise = I8# (x# `iShiftRA#` negateInt# i#) @@ -386,10 +386,10 @@ instance Bits Int16 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (I16# x#) .&. (I16# y#) = I16# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I16# x#) .|. (I16# y#) = I16# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I16# x#) = I16# (word2Int# (not# (int2Word# x#))) + (I16# x#) .&. (I16# y#) = I16# (x# `andI#` y#) + (I16# x#) .|. (I16# y#) = I16# (x# `orI#` y#) + (I16# x#) `xor` (I16# y#) = I16# (x# `xorI#` y#) + complement (I16# x#) = I16# (notI# x#) (I16# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I16# (narrow16Int# (x# `iShiftL#` i#)) | otherwise = I16# (x# `iShiftRA#` negateInt# i#) @@ -595,10 +595,10 @@ instance Bits Int32 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (I32# x#) .&. (I32# y#) = I32# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I32# x#) .|. (I32# y#) = I32# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I32# x#) = I32# (word2Int# (not# (int2Word# x#))) + (I32# x#) .&. (I32# y#) = I32# (x# `andI#` y#) + (I32# x#) .|. (I32# y#) = I32# (x# `orI#` y#) + (I32# x#) `xor` (I32# y#) = I32# (x# `xorI#` y#) + complement (I32# x#) = I32# (notI# x#) (I32# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I32# (narrow32Int# (x# `iShiftL#` i#)) | otherwise = I32# (x# `iShiftRA#` negateInt# i#) @@ -1014,10 +1014,10 @@ instance Bits Int64 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (I64# x#) .&. (I64# y#) = I64# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I64# x#) .|. (I64# y#) = I64# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) + (I64# x#) .&. (I64# y#) = I64# (x# `andI#` y#) + (I64# x#) .|. (I64# y#) = I64# (x# `orI#` y#) + (I64# x#) `xor` (I64# y#) = I64# (x# `xorI#` y#) + complement (I64# x#) = I64# (notI# x#) (I64# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I64# (x# `iShiftL#` i#) | otherwise = I64# (x# `iShiftRA#` negateInt# i#) diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs index 6f6d9d670a..65fa4f54a5 100644 --- a/libraries/base/GHC/List.hs +++ b/libraries/base/GHC/List.hs @@ -87,7 +87,7 @@ last [] = errorEmptyList "last" #else -- Use foldl to make last a good consumer. -- This will compile to good code for the actual GHC.List.last. --- (At least as long it is eta-expaned, otherwise it does not, #10260.) +-- (At least as long it is eta-expanded, otherwise it does not, #10260.) last xs = foldl (\_ x -> x) lastError xs {-# INLINE last #-} -- The inline pragma is required to make GHC remember the implementation via @@ -400,7 +400,7 @@ strictUncurryScanr f pair = case pair of scanrFB :: (a -> b -> b) -> (b -> c -> c) -> a -> (b, c) -> (b, c) scanrFB f c = \x ~(r, est) -> (f x r, r `c` est) -- This lazy pattern match on the tuple is necessary to prevent --- an infinite loop when scanr recieves a fusable infinite list, +-- an infinite loop when scanr receives a fusable infinite list, -- which was the reason for #16943. -- See Note [scanrFB and evaluation] below diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs index a79f405079..14e4a9b7e2 100644 --- a/libraries/base/GHC/Read.hs +++ b/libraries/base/GHC/Read.hs @@ -414,7 +414,7 @@ readSymField fieldName readVal = do -- typecheck/TcGenDeriv.hs) would generate inline code for parsing fields; -- this, however, turned out to produce massive amounts of intermediate code, -- and produced a considerable performance hit in the code generator. --- Since Read instances are not generally supposed to be perfomance critical, +-- Since Read instances are not generally supposed to be performance critical, -- the readField and readSymField functions have been factored out, and the -- code generator now just generates calls rather than manually inlining the -- parsers. For large record types (e.g. 500 fields), this produces a diff --git a/libraries/base/System/CPUTime.hsc b/libraries/base/System/CPUTime.hsc index 6bc90f168a..5b0fdbf4da 100644 --- a/libraries/base/System/CPUTime.hsc +++ b/libraries/base/System/CPUTime.hsc @@ -40,7 +40,7 @@ import qualified System.CPUTime.Posix.ClockGetTime as I #elif defined(HAVE_GETRUSAGE) && ! solaris2_HOST_OS import qualified System.CPUTime.Posix.RUsage as I --- @getrusage()@ is right royal pain to deal with when targetting multiple +-- @getrusage()@ is right royal pain to deal with when targeting multiple -- versions of Solaris, since some versions supply it in libc (2.3 and 2.5), -- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back -- again in libucb in 2.6..) diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc index 3c9d36cb88..cdf39ea041 100644 --- a/libraries/base/System/Environment/ExecutablePath.hsc +++ b/libraries/base/System/Environment/ExecutablePath.hsc @@ -39,6 +39,7 @@ import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import System.Posix.Internals +#include <sys/types.h> #include <sys/sysctl.h> #elif defined(mingw32_HOST_OS) import Control.Exception diff --git a/libraries/base/System/IO/Error.hs b/libraries/base/System/IO/Error.hs index 2585181df8..3417b910e5 100644 --- a/libraries/base/System/IO/Error.hs +++ b/libraries/base/System/IO/Error.hs @@ -176,7 +176,7 @@ isUserError = isUserErrorType . ioeGetErrorType -- | An error indicating that the operation failed because the -- resource vanished. See 'resourceVanishedErrorType'. -- --- @since 0.4.14.0 +-- @since 4.14.0.0 isResourceVanishedError :: IOError -> Bool isResourceVanishedError = isResourceVanishedErrorType . ioeGetErrorType @@ -224,7 +224,7 @@ userErrorType = UserError -- This happens when, for example, attempting to write to a closed -- socket or attempting to write to a named pipe that was deleted. -- --- @since 0.4.14.0 +-- @since 4.14.0.0 resourceVanishedErrorType :: IOErrorType resourceVanishedErrorType = ResourceVanished @@ -279,7 +279,7 @@ isUserErrorType _ = False -- | I\/O error where the operation failed because the resource vanished. -- See 'resourceVanishedErrorType'. -- --- @since 0.4.14.0 +-- @since 4.14.0.0 isResourceVanishedErrorType :: IOErrorType -> Bool isResourceVanishedErrorType ResourceVanished = True isResourceVanishedErrorType _ = False diff --git a/libraries/base/tests/IO/T2122.hs b/libraries/base/tests/IO/T2122.hs index 488d2434bc..2969cdaf28 100644 --- a/libraries/base/tests/IO/T2122.hs +++ b/libraries/base/tests/IO/T2122.hs @@ -34,7 +34,7 @@ main = do writeFile fp "test" test True --- fails everytime when causeFailure is True in GHCi, with runhaskell, +-- fails every time when causeFailure is True in GHCi, with runhaskell, -- or when compiled. test :: Bool -> IO () test causeFailure = diff --git a/libraries/ghc-boot/GHC/BaseDir.hs b/libraries/ghc-boot/GHC/BaseDir.hs index 196ab2eb72..656e4014db 100644 --- a/libraries/ghc-boot/GHC/BaseDir.hs +++ b/libraries/ghc-boot/GHC/BaseDir.hs @@ -33,7 +33,7 @@ expandTopDir = expandPathVar "topdir" -- | @expandPathVar var value str@ -- --- replaces occurences of variable @$var@ with @value@ in str. +-- replaces occurrences of variable @$var@ with @value@ in str. expandPathVar :: String -> FilePath -> String -> String expandPathVar var value str | Just str' <- stripPrefix ('$':var) str diff --git a/libraries/ghc-heap/tests/closure_size.hs b/libraries/ghc-heap/tests/closure_size.hs index d760f22efa..85d860fbf4 100644 --- a/libraries/ghc-heap/tests/closure_size.hs +++ b/libraries/ghc-heap/tests/closure_size.hs @@ -12,7 +12,6 @@ data A = A (Array# Int) data MA = MA (MutableArray# RealWorld Int) data BA = BA ByteArray# data MBA = MBA (MutableByteArray# RealWorld) -data B = B BCO# data APC a = APC a diff --git a/libraries/ghc-heap/tests/heap_all.hs b/libraries/ghc-heap/tests/heap_all.hs index 1560d4d9e8..fa536a2d30 100644 --- a/libraries/ghc-heap/tests/heap_all.hs +++ b/libraries/ghc-heap/tests/heap_all.hs @@ -197,7 +197,6 @@ data A = A (Array# Int) data MA = MA (MutableArray# RealWorld Int) data BA = BA ByteArray# data MBA = MBA (MutableByteArray# RealWorld) -data B = B BCO# data APC a = APC a main :: IO () @@ -220,9 +219,8 @@ main = do (# s1, x #) -> case unsafeFreezeByteArray# x s1 of (# s2, y #) -> (# s2, BA y #) - B bco <- IO $ \s -> - case newBCO# ba ba a 0# ba s of - (# s1, x #) -> (# s1, B x #) + bco <- IO $ \s -> + newBCO# ba ba a 0# ba s APC apc <- IO $ \s -> case mkApUpd0# bco of (# x #) -> (# s, APC x #) diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index 411d118aa1..cf14d21c81 100644 --- a/libraries/ghc-prim/changelog.md +++ b/libraries/ghc-prim/changelog.md @@ -27,6 +27,16 @@ reverses the order of its bits e.g. `0b110001` becomes `0b100011`. These primitives use optimized machine instructions when available. +- Add Int# multiplication primop: + + timesInt2# :: Int# -> Int# -> (# Int#, Int#, Int# #) + + `timesInt2#` computes the multiplication of its two parameters and returns a + triple (isHighNeeded,high,low) where high and low are respectively the high + and low bits of the double-word result. isHighNeeded is a cheap way to test + if the high word is a sign-extension of the low word (isHighNeeded = 0#) or + not (isHighNeeded = 1#). + ## 0.6.0 - Shipped with GHC 8.8.1 diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs index 96fc4418ff..7098c27fb8 100644 --- a/libraries/ghci/GHCi/CreateBCO.hs +++ b/libraries/ghci/GHCi/CreateBCO.hs @@ -23,6 +23,7 @@ import System.IO (fixIO) import Control.Monad import Data.Array.Base import Foreign hiding (newArray) +import Unsafe.Coerce (unsafeCoerce) import GHC.Arr ( Array(..) ) import GHC.Exts import GHC.IO @@ -44,7 +45,9 @@ createBCO _ ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian , "mixed endianness setup is not supported!" ]) createBCO arr bco - = do BCO bco# <- linkBCO' arr bco + = do linked_bco <- linkBCO' arr bco + -- Note [Updatable CAF BCOs] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- Why do we need mkApUpd0 here? Otherwise top-level -- interpreted CAFs don't get updated after evaluation. A -- top-level BCO will evaluate itself and return its value @@ -57,9 +60,10 @@ createBCO arr bco -- (c) An AP is always fully saturated, so we *can't* wrap -- non-zero arity BCOs in an AP thunk. -- + -- See #17424. if (resolvedBCOArity bco > 0) - then return (HValue (unsafeCoerce# bco#)) - else case mkApUpd0# bco# of { (# final_bco #) -> + then return (HValue (unsafeCoerce linked_bco)) + else case mkApUpd0# linked_bco of { (# final_bco #) -> return (HValue final_bco) } @@ -102,8 +106,8 @@ mkPtrsArray arr n_ptrs ptrs = do fill (ResolvedBCOStaticPtr r) i = do writePtrsArrayPtr i (fromRemotePtr r) marr fill (ResolvedBCOPtrBCO bco) i = do - BCO bco# <- linkBCO' arr bco - writePtrsArrayBCO i bco# marr + bco <- linkBCO' arr bco + writePtrsArrayBCO i bco marr fill (ResolvedBCOPtrBreakArray r) i = do BA mba <- localRef r writePtrsArrayMBA i mba marr @@ -130,23 +134,20 @@ writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s -> writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s -writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO () +writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO () writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s -> case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #) -data BCO = BCO BCO# - writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s -> case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #) newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO newBCO instrs lits ptrs arity bitmap = IO $ \s -> - case newBCO# instrs lits ptrs arity bitmap s of - (# s1, bco #) -> (# s1, BCO bco #) + newBCO# instrs lits ptrs arity bitmap s {- Note [BCO empty array] - + ~~~~~~~~~~~~~~~~~~~~~~ Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free: they are 2-word heap objects. So let's make a single empty array and share it between all BCOs. diff --git a/libraries/ghci/GHCi/RemoteTypes.hs b/libraries/ghci/GHCi/RemoteTypes.hs index c024ae9fff..6a552f37da 100644 --- a/libraries/ghci/GHCi/RemoteTypes.hs +++ b/libraries/ghci/GHCi/RemoteTypes.hs @@ -33,7 +33,7 @@ import GHC.ForeignPtr -- Static pointers only; don't use this for heap-resident pointers. -- Instead use HValueRef. We will fix the remote pointer to be 64 bits. This -- should cover 64 and 32bit systems, and permits the exchange of remote ptrs --- between machines of different word size. For exmaple, when connecting to +-- between machines of different word size. For example, when connecting to -- an iserv instance on a different architecture with different word size via -- -fexternal-interpreter. newtype RemotePtr a = RemotePtr Word64 diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs index 14bdb57ffd..1b7d6cafba 100644 --- a/libraries/integer-gmp/src/GHC/Integer/Type.hs +++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs @@ -51,7 +51,7 @@ default () -- -- {-# CONSTANT_FOLDED plusInteger #-} -- --- which is simply expaned into a +-- which is simply expanded into a -- -- {-# NOINLINE plusInteger #-} -- @@ -478,10 +478,9 @@ timesInteger x (S# 1#) = x timesInteger (S# 1#) y = y timesInteger x (S# -1#) = negateInteger x timesInteger (S# -1#) y = negateInteger y -timesInteger (S# x#) (S# y#) - = case mulIntMayOflo# x# y# of - 0# -> S# (x# *# y#) - _ -> timesInt2Integer x# y# +timesInteger (S# x#) (S# y#) = case timesInt2# x# y# of + (# 0#, _h, l #) -> S# l + (# _ , h, l #) -> int2ToInteger h l timesInteger x@(S# _) y = timesInteger y x -- no S# as first arg from here on timesInteger (Jp# x) (Jp# y) = Jp# (timesBigNat x y) @@ -504,6 +503,22 @@ sqrInteger (S# j#) = timesInt2Integer j# j# sqrInteger (Jp# bn) = Jp# (sqrBigNat bn) sqrInteger (Jn# bn) = Jp# (sqrBigNat bn) +-- | Convert two Int# (resp. high and low bits of a double-word Int#) into an +-- Integer +-- +-- Warning: currently it doesn't handle the case where high=minBound and low=0 +-- (i.e. high:low = 100......00 = minBound for a double-word Int) +int2ToInteger :: Int# -> Int# -> Integer +int2ToInteger h l + | isTrue# (h <# 0#) = + case addWordC# (not# (int2Word# l)) 1## of -- two's complement... + (# lw,c #) -> Jn# (wordToBigNat2 + -- add the carry to the high word + (int2Word# c `plusWord#` not# (int2Word# h)) + lw + ) + | True = Jp# (wordToBigNat2 (int2Word# h) (int2Word# l)) + -- | Construct 'Integer' from the product of two 'Int#'s timesInt2Integer :: Int# -> Int# -> Integer timesInt2Integer x# y# = case (# isTrue# (x# >=# 0#), isTrue# (y# >=# 0#) #) of diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 461f213813..ef9a718111 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -788,7 +788,7 @@ instance Ppr Type where ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty] ppr (ForallVisT tvars ty) = sep [pprForallVis tvars [], ppr ty] ppr ty = pprTyApp (split ty) - -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind) + -- Works, in a degenerate way, for SigT, and puts parens round (ty :: kind) -- See Note [Pretty-printing kind signatures] instance Ppr TypeArg where ppr (TANormal ty) = ppr ty diff --git a/mk/project.mk.in b/mk/project.mk.in index 9ee2eab59f..21d5f6f683 100644 --- a/mk/project.mk.in +++ b/mk/project.mk.in @@ -142,7 +142,7 @@ else Windows_Host=NO endif -# Windows_Target=YES if we are targetting a Windows platform +# Windows_Target=YES if we are targeting a Windows platform ifneq "$(findstring $(TargetOS_CPP), mingw32)" "" Windows_Target=YES else diff --git a/nofib b/nofib -Subproject a6cbac8fd8c69d85fddfde0a2686607e1ae2294 +Subproject c9fe4e92b88cd052d5fea8b713569d16c05ebf0 diff --git a/rts/Apply.cmm b/rts/Apply.cmm index eeb760c5ed..dcfaa446f2 100644 --- a/rts/Apply.cmm +++ b/rts/Apply.cmm @@ -571,7 +571,7 @@ being carried out by TSO 2 and attempt to suspend it. The suspension process proceeds by invoking raiseAsync, which walks the stack from the top looking for update frames. For each update frame we take any stack -frames preceeding it and construct an AP_STACK heap object from them. We then +frames preceding it and construct an AP_STACK heap object from them. We then replace the updatee of the frame with an indirection pointing to the AP_STACK. So, after suspending the first update frame we have, @@ -373,7 +373,7 @@ freeHpcModuleInfo (HpcModuleInfo *mod) } /* Called at the end of execution, to write out the Hpc *.tix file - * for this exection. Safe to call, even if coverage is not used. + * for this execution. Safe to call, even if coverage is not used. */ void exitHpc(void) { diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h index 5cd35f2e5b..0f47b82761 100644 --- a/rts/LinkerInternals.h +++ b/rts/LinkerInternals.h @@ -361,7 +361,7 @@ void freeSegments(ObjectCode *oc); #define MAP_ANONYMOUS MAP_ANON #endif -/* Which object file format are we targetting? */ +/* Which object file format are we targeting? */ #if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) \ || defined(linux_android_HOST_OS) \ || defined(freebsd_HOST_OS) || defined(kfreebsdgnu_HOST_OS) \ diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 97c4b35a71..a836c5bf2a 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -374,7 +374,7 @@ computeRetainerSet( traverseState *ts ) // all are guaranteed to be valid, or reachable. // // The following code assumes that WEAK objects are considered to be roots - // for retainer profilng. + // for retainer profiling. for (n = 0; n < n_capabilities; n++) { // NB: after a GC, all nursery weak_ptr_lists have been migrated // to the global lists living in the generations diff --git a/rts/StablePtr.c b/rts/StablePtr.c index 2181b83d90..edcd863183 100644 --- a/rts/StablePtr.c +++ b/rts/StablePtr.c @@ -32,7 +32,7 @@ for garbage collection because the act of passing them makes a copy from the heap, stack or wherever they are onto the C-world stack. However, if we were to pass a heap object such as a (Haskell) @String@ - and a garbage collection occured before we finished using it, we'd run + and a garbage collection occurred before we finished using it, we'd run into problems since the heap object might have been moved or even deleted. diff --git a/rts/StgCRun.c b/rts/StgCRun.c index 934926e0f3..a6ef7054a4 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -131,7 +131,7 @@ STG_NO_OPTIMIZE StgWord8 *win32AllocStack(void) * ABI requires this (x64, Mac OSX 32bit/64bit) as well as interfacing with * other libraries through the FFI. * - * As part of this arrangment we must maintain the stack at a 16-byte boundary + * As part of this arrangement we must maintain the stack at a 16-byte boundary * - word_size-bytes (so 16n - 4 for i386 and 16n - 8 for x64) on entry to a * procedure since both GCC and LLVM expect this. This is because the stack * should have been 16-byte boundary aligned and then a call made which pushes diff --git a/rts/linker/M32Alloc.c b/rts/linker/M32Alloc.c index dbba711df4..148a5043cf 100644 --- a/rts/linker/M32Alloc.c +++ b/rts/linker/M32Alloc.c @@ -96,7 +96,7 @@ life-cycle it is in: allocation) Allocation (in the case of a small request) consists of walking the nursery to -find a page that will accomodate the request. If none exists then we allocate a +find a page that will accommodate the request. If none exists then we allocate a new nursery page (flushing an existing one to the filled list if the nursery is full). diff --git a/rts/linker/MachO.c b/rts/linker/MachO.c index 5ae7620fc7..12e84578fc 100644 --- a/rts/linker/MachO.c +++ b/rts/linker/MachO.c @@ -427,7 +427,7 @@ isGotLoad(struct relocation_info * ri) { /* This is very similar to makeSymbolExtra * However, as we load sections into different - * pages, that may be further appart than + * pages, that may be further apart than * branching allows, we'll use some extra * space at the end of each section allocated * for stubs. diff --git a/rts/linker/PEi386.c b/rts/linker/PEi386.c index 2f65f6a208..81308779a1 100644 --- a/rts/linker/PEi386.c +++ b/rts/linker/PEi386.c @@ -105,7 +105,7 @@ contain the name of the actual dll to load. This will be the only content of the section. In the symbol table, the last symbol will be the name used to refer to the dll in the relocation tables. This name will always - be in the format "symbol_name_iname", however when refered to, the format + be in the format "symbol_name_iname", however when referred to, the format "_head_symbol_name" is used. We record this symbol early on during GetNames and load the dll and use @@ -1535,7 +1535,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) } setImportSymbol (oc, sname); - /* Don't process this oc any futher. Just exit. */ + /* Don't process this oc any further. Just exit. */ oc->n_symbols = 0; oc->symbols = NULL; stgFree (oc->image); diff --git a/rts/posix/OSMem.c b/rts/posix/OSMem.c index 15f1b62dc9..8e797681c9 100644 --- a/rts/posix/OSMem.c +++ b/rts/posix/OSMem.c @@ -183,7 +183,7 @@ my_mmap (void *addr, W_ size, int operation) #if defined(darwin_HOST_OS) // Without MAP_FIXED, Apple's mmap ignores addr. - // With MAP_FIXED, it overwrites already mapped regions, whic + // With MAP_FIXED, it overwrites already mapped regions, which // mmap(0, ... MAP_FIXED ...) is worst of all: It unmaps the program text // and replaces it with zeroes, causing instant death. // This behaviour seems to be conformant with IEEE Std 1003.1-2001. diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 83e9c97bd9..a560c2c8fd 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -743,7 +743,7 @@ GarbageCollect (uint32_t collect_gen, // oldest_gen->scavenged_large_objects back to oldest_gen->large_objects. ASSERT(oldest_gen->scavenged_large_objects == NULL); if (RtsFlags.GcFlags.useNonmoving && major_gc) { - // All threads in non-moving heap should be found to be alive, becuase + // All threads in non-moving heap should be found to be alive, because // threads in the non-moving generation's list should live in the // non-moving heap, and we consider non-moving objects alive during // preparation. diff --git a/rts/sm/NonMoving.c b/rts/sm/NonMoving.c index 20ec5a45ba..5cb7c8b7e5 100644 --- a/rts/sm/NonMoving.c +++ b/rts/sm/NonMoving.c @@ -200,7 +200,7 @@ Mutex concurrent_coll_finished_lock; * generation. * * - Note [Aging under the non-moving collector] (NonMoving.c) describes how - * we accomodate aging + * we accommodate aging * * - Note [Large objects in the non-moving collector] (NonMovingMark.c) * describes how we track large objects. @@ -890,7 +890,7 @@ void nonmovingCollect(StgWeak **dead_weaks, StgTSO **resurrected_threads) // If we're interrupting or shutting down, do not let this capability go and // run a STW collection. Reason: we won't be able to acquire this capability // again for the sync if we let it go, because it'll immediately start doing - // a major GC, becuase that's what we do when exiting scheduler (see + // a major GC, because that's what we do when exiting scheduler (see // exitScheduler()). if (sched_state == SCHED_RUNNING) { concurrent_coll_running = true; diff --git a/rts/sm/NonMovingMark.c b/rts/sm/NonMovingMark.c index 085d7827df..3ebd039c43 100644 --- a/rts/sm/NonMovingMark.c +++ b/rts/sm/NonMovingMark.c @@ -88,7 +88,7 @@ memcount n_nonmoving_marked_compact_blocks = 0; * move the same large object to nonmoving_marked_large_objects more than once. */ static Mutex nonmoving_large_objects_mutex; -// Note that we don't need a similar lock for compact objects becuase we never +// Note that we don't need a similar lock for compact objects because we never // mark a compact object eagerly in a write barrier; all compact objects are // marked by the mark thread, so there can't be any races here. #endif diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index f04b3c5929..cdae368150 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -406,7 +406,7 @@ freeStorage (bool free_heap) but can assume only two bits are available in STATIC_LINK (due to 32-bit systems). - To accomodate this we move handling of static objects entirely to the + To accommodate this we move handling of static objects entirely to the oldest generation when the nonmoving collector is in use. To do this safely and efficiently we allocate the blackhole created by lockCAF() directly in the non-moving heap. This means that the moving collector can completely diff --git a/testsuite/driver/my_typing.py b/testsuite/driver/my_typing.py index a31775d7f2..c3f3e02fe7 100644 --- a/testsuite/driver/my_typing.py +++ b/testsuite/driver/my_typing.py @@ -24,8 +24,11 @@ except: # is taken. We exploit this below. # TextIO is missing on some older Pythons. -if 'TextIO' in globals(): - TextIO = typing.TextIO +if 'TextIO' not in globals(): + try: + TextIO = typing.TextIO + except ImportError: + TextIO = None # type: ignore else: TextIO = None # type: ignore diff --git a/testsuite/driver/perf_notes.py b/testsuite/driver/perf_notes.py index cfbd5e529f..cebb8f9815 100644 --- a/testsuite/driver/perf_notes.py +++ b/testsuite/driver/perf_notes.py @@ -517,7 +517,7 @@ def get_commit_metric(gitNoteRef, # tolerance_dev: allowed deviation of the actual value from the expected value. # allowed_perf_changes: allowed changes in stats. This is a dictionary as returned by get_allowed_perf_changes(). # force_print: Print stats even if the test stat was in the tolerance range. -# Returns a (MetricChange, pass/fail object) tuple. Passes if the stats are withing the expected value ranges. +# Returns a (MetricChange, pass/fail object) tuple. Passes if the stats are within the expected value ranges. def check_stats_change(actual: PerfStat, baseline: Baseline, tolerance_dev, diff --git a/testsuite/driver/testglobals.py b/testsuite/driver/testglobals.py index c39ca7a8c9..2393247b22 100644 --- a/testsuite/driver/testglobals.py +++ b/testsuite/driver/testglobals.py @@ -133,7 +133,7 @@ class TestConfig: # Do we have SMP support? self.have_smp = False - # Is gdb avaliable? + # Is gdb available? self.have_gdb = False # Is readelf available? diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index 79d504a845..07206799c1 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -1379,7 +1379,7 @@ def metric_dict(name, way, metric, value) -> PerfStat: # way: the way. # stats_file: the path of the stats_file containing the stats for the test. # range_fields: see TestOptions.stats_range_fields -# Returns a pass/fail object. Passes if the stats are withing the expected value ranges. +# Returns a pass/fail object. Passes if the stats are within the expected value ranges. # This prints the results for the user. def check_stats(name: TestName, way: WayName, diff --git a/testsuite/driver/typing_stubs.py b/testsuite/driver/typing_stubs.py new file mode 100644 index 0000000000..6f17b5a35c --- /dev/null +++ b/testsuite/driver/typing_stubs.py @@ -0,0 +1,23 @@ +# Stub definitions for things provided by the typing package +# for use by older Python versions. + +import collections + +class Dummy: + def __getitem__(self, *args): + return None + +List = Dummy() +Tuple = Dummy() +Set = Dummy() +TextIO = Dummy() +Iterator = Dummy() +Callable = Dummy() +Optional = Dummy() +Dict = Dummy() +Union = Dummy() +Any = Dummy() + +NewType = lambda name, ty: ty +def NamedTuple(name, fields): + return collections.namedtuple(name, [field[0] for field in fields]) diff --git a/testsuite/tests/annotations/should_compile/th/annth_compunits.stdout b/testsuite/tests/annotations/should_compile/th/annth_compunits.stdout index 51fa405556..33199d9331 100644 --- a/testsuite/tests/annotations/should_compile/th/annth_compunits.stdout +++ b/testsuite/tests/annotations/should_compile/th/annth_compunits.stdout @@ -1,4 +1,4 @@ -["TH module annotation","addTopDecls module annotation","Module annotation"] +["addTopDecls module annotation","TH module annotation","Module annotation"] ["Value annotation"] ["TH Value annotation","addTopDecls value annotation"] ["Type annotation"] diff --git a/testsuite/tests/annotations/should_compile/th/annth_make.stdout b/testsuite/tests/annotations/should_compile/th/annth_make.stdout index 51fa405556..33199d9331 100644 --- a/testsuite/tests/annotations/should_compile/th/annth_make.stdout +++ b/testsuite/tests/annotations/should_compile/th/annth_make.stdout @@ -1,4 +1,4 @@ -["TH module annotation","addTopDecls module annotation","Module annotation"] +["addTopDecls module annotation","TH module annotation","Module annotation"] ["Value annotation"] ["TH Value annotation","addTopDecls value annotation"] ["Type annotation"] diff --git a/testsuite/tests/annotations/should_run/annrun01.stdout b/testsuite/tests/annotations/should_run/annrun01.stdout index b57394b563..46df141776 100644 --- a/testsuite/tests/annotations/should_run/annrun01.stdout +++ b/testsuite/tests/annotations/should_run/annrun01.stdout @@ -4,7 +4,7 @@ Loading Targets Finding Module Getting Module Info Showing Details For Module -([10],[],["Rock!!!!","Annotations","Module"],[]) +([10],[],["Module","Annotations","Rock!!!!"],[]) Showing Details For Exports ([],[Just True],["Type Annotation"],[Annrun01_Help.Baz]) ([],[],[],[]) diff --git a/testsuite/tests/arrows/should_compile/T5333.hs b/testsuite/tests/arrows/should_compile/T5333.hs index 808b8a207b..e865b52f12 100644 --- a/testsuite/tests/arrows/should_compile/T5333.hs +++ b/testsuite/tests/arrows/should_compile/T5333.hs @@ -7,7 +7,7 @@ import Control.Arrow cc1 :: a e b -> a e b -> a e b cc1 = undefined --- With GHC < 7.10.1, the following compile failures occured: +-- With GHC < 7.10.1, the following compile failures occurred: -- -- ghc: panic! (the 'impossible' happened) -- (GHC version 7.8.4 for x86_64-unknown-linux): diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index f96820de81..01516136c2 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -88,6 +88,7 @@ test('cgrun075', normal, compile_and_run, ['']) test('cgrun076', normal, compile_and_run, ['']) test('cgrun077', [when(have_cpu_feature('bmi2'), extra_hc_opts('-mbmi2'))], compile_and_run, ['']) test('cgrun078', omit_ways(['ghci']), compile_and_run, ['']) +test('cgrun079', normal, compile_and_run, ['']) test('T1852', normal, compile_and_run, ['']) test('T1861', extra_run_opts('0'), compile_and_run, ['']) diff --git a/testsuite/tests/codeGen/should_run/cgrun079.hs b/testsuite/tests/codeGen/should_run/cgrun079.hs new file mode 100644 index 0000000000..e299c860c3 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/cgrun079.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP, MagicHash, BlockArguments, UnboxedTuples #-} + +-- Tests for the timesInt2# primop +module Main ( main ) where + +import Data.Bits +import GHC.Int +import GHC.Prim +import GHC.Word +import Control.Monad + +#include "MachDeps.h" + + +imul2 :: Int -> Int -> (Int,Int,Int) +imul2 (I# x) (I# y) = case timesInt2# x y of + (# c, h, l #) -> (I# c, I# h, I# l) + +checkImul2 :: Int -> Int -> IO () +checkImul2 x y = do + -- First we compare against Integer result. Note that this test will become + -- moot when Integer implementation will use this primitive + let + w2 = fromIntegral x * (fromIntegral y :: Integer) + (c,h,l) = imul2 x y + w = case c of + 0 -> fromIntegral l + _ -> int2ToInteger h l + + unless (w == w2) do + putStrLn $ mconcat + [ "Failed: " + , show x + , " * " + , show y + , "\n Got: " + , show w + , "\n Expected: " + , show w2 + ] + + -- Now we compare with a generic version using unsigned multiply. + -- This reimplements the fallback generic version that the compiler uses when + -- the mach-op isn't available so it'd better be correct too. + let (c',h',l') = genericIMul2 x y + + unless ((c,h,l) == (c',h',l')) do + putStrLn $ mconcat + [ "Failed: " + , show x + , " * " + , show y + , "\n Got: " + , show (c,h,l) + , "\n Expected: " + , show (c',h',l') + ] + +addWordC :: Word -> Word -> (Word,Word) +addWordC (W# x) (W# y) = case addWordC# x y of + (# l,c #) -> (W# (int2Word# c), W# l) + +int2ToInteger :: Int -> Int -> Integer +int2ToInteger h l + | h < 0 = case addWordC (complement (fromIntegral l)) 1 of + (c,w) -> -1 * word2ToInteger (c + complement (fromIntegral h)) w + | otherwise = word2ToInteger (fromIntegral h) (fromIntegral l) + where + word2ToInteger :: Word -> Word -> Integer + word2ToInteger x y = (fromIntegral x) `shiftL` WORD_SIZE_IN_BITS + fromIntegral y + +timesWord2 :: Word -> Word -> (Int,Int) +timesWord2 (W# x) (W# y) = case timesWord2# x y of + (# h, l #) -> (I# (word2Int# h), I# (word2Int# l)) + +genericIMul2 :: Int -> Int -> (Int,Int,Int) +genericIMul2 x y = (c,h,l) + where + (p,l) = timesWord2 (fromIntegral x) (fromIntegral y) + h = p - f x y - f y x + c = if h == carryFill l then 0 else 1 + f u v = carryFill u .&. v + + -- Return either 00..00 or FF..FF depending on the carry + carryFill :: Int -> Int + carryFill x = x `shiftR` (WORD_SIZE_IN_BITS - 1) + + +main = do + checkImul2 10 10 + checkImul2 10 (-10) + checkImul2 minBound (-1) + checkImul2 maxBound (-1) + checkImul2 minBound 0 + checkImul2 maxBound 0 + checkImul2 minBound minBound + checkImul2 minBound maxBound + checkImul2 maxBound maxBound diff --git a/testsuite/tests/concurrent/prog001/Arithmetic.hs b/testsuite/tests/concurrent/prog001/Arithmetic.hs index a1253969b0..bce3ff6400 100644 --- a/testsuite/tests/concurrent/prog001/Arithmetic.hs +++ b/testsuite/tests/concurrent/prog001/Arithmetic.hs @@ -32,7 +32,7 @@ plusOne (0:xs) = 1:fl xs --- Substraction by 1, the input must be in (0,1) +-- Subtraction by 1, the input must be in (0,1) minusOne :: Gray -> Gray minusOne (1:xs) = 0:fl xs diff --git a/testsuite/tests/cps/cps021.cmm b/testsuite/tests/cps/cps021.cmm index fa7e809ee0..db67d97da2 100644 --- a/testsuite/tests/cps/cps021.cmm +++ b/testsuite/tests/cps/cps021.cmm @@ -1,4 +1,4 @@ -// Verify jumping to the begining of the current continuation +// Verify jumping to the beginning of the current continuation // is done with a branch and not a jump foo() { diff --git a/testsuite/tests/deSugar/should_compile/T12944.hs b/testsuite/tests/deSugar/should_compile/T12944.hs index 076812d6e7..540ea06e81 100644 --- a/testsuite/tests/deSugar/should_compile/T12944.hs +++ b/testsuite/tests/deSugar/should_compile/T12944.hs @@ -31,7 +31,7 @@ instance (AdditiveGroup (poly a), Num a) => AdditiveGroup (IntOfLog poly a) wher IntOfLog k p ^+^ IntOfLog k' p' = IntOfLog (k + k') (p ^+^ p') negateV (IntOfLog k p) = IntOfLog (negate k) (negateV p) {-# SPECIALISE instance Num a => AdditiveGroup (IntOfLog Poly1 a) #-} - -- This pragmas casued the crash + -- This pragmas caused the crash instance (VectorSpace (poly a), Scalar (poly a) ~ a, Num a) => VectorSpace (IntOfLog poly a) where type Scalar (IntOfLog poly a) = a diff --git a/testsuite/tests/deriving/should_fail/T7148a.hs b/testsuite/tests/deriving/should_fail/T7148a.hs index 6441058b24..fd4a8fcda6 100644 --- a/testsuite/tests/deriving/should_fail/T7148a.hs +++ b/testsuite/tests/deriving/should_fail/T7148a.hs @@ -19,7 +19,7 @@ instance Convert (SAFE a) where newtype IS_NO_LONGER a = IS_NO_LONGER a deriving Convert type instance Result (IS_NO_LONGER a) b = b ---infered type is +--inferred type is unsafeCoerce :: forall a b. a -> b unsafeCoerce = coerce (Proxy :: Proxy b) . IS_NO_LONGER . SAFE @@ -34,4 +34,4 @@ crash = unsafeCoerce . tail . tail . tail . unsafeCoerce $ True --time for side effects unsafePerformIO :: IO a -> a -unsafePerformIO x = runST $ unsafeCoerce x
\ No newline at end of file +unsafePerformIO x = runST $ unsafeCoerce x diff --git a/testsuite/tests/gadt/T9096.hs b/testsuite/tests/gadt/T9096.hs deleted file mode 100644 index d778798d36..0000000000 --- a/testsuite/tests/gadt/T9096.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module T9096 where - -data Foo a where - MkFoo :: (->) a (Foo a) diff --git a/testsuite/tests/gadt/all.T b/testsuite/tests/gadt/all.T index be7177445e..29bde94100 100644 --- a/testsuite/tests/gadt/all.T +++ b/testsuite/tests/gadt/all.T @@ -110,7 +110,6 @@ test('T7294', normal, compile, ['']) test('T7321', [], makefile_test, []) test('T7974', normal, compile, ['']) test('T7558', normal, compile_fail, ['']) -test('T9096', normal, compile, ['']) test('T9380', normal, compile_and_run, ['']) test('T12087', normal, compile_fail, ['']) test('T12468', normal, compile_fail, ['']) diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 184070c630..3a0d4ff0fb 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -35,12 +35,12 @@ main = do removeFile "Test.hs" print ok where - isDataCon (dL->L _ (AbsBinds { abs_binds = bs })) + isDataCon (L _ (AbsBinds { abs_binds = bs })) = not (isEmptyBag (filterBag isDataCon bs)) - isDataCon (dL->L l (f@FunBind {})) - | (MG _ (dL->L _ (m:_)) _) <- fun_matches f, - ((dL->L _ (c@ConPatOut{})):_)<-hsLMatchPats m, - (dL->L l _)<-pat_con c + isDataCon (L l (f@FunBind {})) + | (MG _ (L _ (m:_)) _) <- fun_matches f, + ((L _ (c@ConPatOut{})):_)<-hsLMatchPats m, + (L l _)<-pat_con c = isGoodSrcSpan l -- Check that the source location is a good one isDataCon _ = False diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile index 3972e3d239..5f0fea1cc7 100644 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ b/testsuite/tests/ghc-api/annotations/Makefile @@ -169,3 +169,7 @@ T16279: .PHONY: T17388 T17388: $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17388.hs + +.PHONY: T17519 +T17519: + $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17519.hs diff --git a/testsuite/tests/ghc-api/annotations/T10268.stdout b/testsuite/tests/ghc-api/annotations/T10268.stdout index 3739b7b0b7..502d5fcf47 100644 --- a/testsuite/tests/ghc-api/annotations/T10268.stdout +++ b/testsuite/tests/ghc-api/annotations/T10268.stdout @@ -14,7 +14,7 @@ ((Test10268.hs:5:1-17,AnnEqual), [Test10268.hs:5:4]), ((Test10268.hs:5:1-17,AnnFunId), [Test10268.hs:5:1-2]), ((Test10268.hs:5:1-17,AnnSemi), [Test10268.hs:7:1]), -((Test10268.hs:5:6-17,AnnThIdSplice), [Test10268.hs:5:6-17]), +((Test10268.hs:5:6-17,AnnDollar), [Test10268.hs:5:6]), ((Test10268.hs:7:1-27,AnnDcolon), [Test10268.hs:7:6-7]), ((Test10268.hs:7:1-27,AnnSemi), [Test10268.hs:8:1]), ((Test10268.hs:7:9,AnnRarrow), [Test10268.hs:7:11-12]), diff --git a/testsuite/tests/ghc-api/annotations/T10276.stdout b/testsuite/tests/ghc-api/annotations/T10276.stdout index 2ed6318905..77b2dae7a2 100644 --- a/testsuite/tests/ghc-api/annotations/T10276.stdout +++ b/testsuite/tests/ghc-api/annotations/T10276.stdout @@ -29,8 +29,9 @@ ((Test10276.hs:(10,13)-(11,74),AnnClose), [Test10276.hs:11:72-74]), ((Test10276.hs:(10,13)-(11,74),AnnOpen), [Test10276.hs:10:13-15]), ((Test10276.hs:(10,16)-(11,71),AnnVal), [Test10276.hs:10:20]), -((Test10276.hs:10:31-42,AnnCloseP), [Test10276.hs:10:42]), -((Test10276.hs:10:31-42,AnnOpenPTE), [Test10276.hs:10:31-33]), +((Test10276.hs:10:31-42,AnnDollarDollar), [Test10276.hs:10:31-32]), +((Test10276.hs:10:33-42,AnnCloseP), [Test10276.hs:10:42]), +((Test10276.hs:10:33-42,AnnOpenP), [Test10276.hs:10:33]), ((Test10276.hs:11:25-71,AnnCloseP), [Test10276.hs:11:71]), ((Test10276.hs:11:25-71,AnnOpenP), [Test10276.hs:11:25]), ((Test10276.hs:11:26-36,AnnCloseP), [Test10276.hs:11:36]), @@ -50,8 +51,9 @@ ((Test10276.hs:(14,13)-(15,74),AnnClose), [Test10276.hs:15:72-74]), ((Test10276.hs:(14,13)-(15,74),AnnOpenE), [Test10276.hs:14:13-16]), ((Test10276.hs:(14,17)-(15,71),AnnVal), [Test10276.hs:14:21]), -((Test10276.hs:14:32-43,AnnCloseP), [Test10276.hs:14:43]), -((Test10276.hs:14:32-43,AnnOpenPTE), [Test10276.hs:14:32-34]), +((Test10276.hs:14:32-43,AnnDollarDollar), [Test10276.hs:14:32-33]), +((Test10276.hs:14:34-43,AnnCloseP), [Test10276.hs:14:43]), +((Test10276.hs:14:34-43,AnnOpenP), [Test10276.hs:14:34]), ((Test10276.hs:15:25-71,AnnCloseP), [Test10276.hs:15:71]), ((Test10276.hs:15:25-71,AnnOpenP), [Test10276.hs:15:25]), ((Test10276.hs:15:26-36,AnnCloseP), [Test10276.hs:15:36]), diff --git a/testsuite/tests/ghc-api/annotations/T10358.stdout b/testsuite/tests/ghc-api/annotations/T10358.stdout index 604c7dab36..28f516cb5e 100644 --- a/testsuite/tests/ghc-api/annotations/T10358.stdout +++ b/testsuite/tests/ghc-api/annotations/T10358.stdout @@ -16,12 +16,12 @@ ((Test10358.hs:(4,1)-(8,6),AnnSemi), [Test10358.hs:9:1]), ((Test10358.hs:(5,3)-(8,6),AnnIn), [Test10358.hs:8:3-4]), ((Test10358.hs:(5,3)-(8,6),AnnLet), [Test10358.hs:5:3-5]), -((Test10358.hs:5:7-16,AnnBang), [Test10358.hs:5:7]), +((Test10358.hs:5:7-10,AnnBang), [Test10358.hs:5:7]), ((Test10358.hs:5:7-16,AnnEqual), [Test10358.hs:5:12]), ((Test10358.hs:5:7-16,AnnFunId), [Test10358.hs:5:8-10]), ((Test10358.hs:5:7-16,AnnSemi), [Test10358.hs:5:17]), ((Test10358.hs:5:14-16,AnnVal), [Test10358.hs:5:15]), -((Test10358.hs:5:19-32,AnnBang), [Test10358.hs:5:19]), +((Test10358.hs:5:19-22,AnnBang), [Test10358.hs:5:19]), ((Test10358.hs:5:19-32,AnnEqual), [Test10358.hs:5:24]), ((Test10358.hs:5:19-32,AnnFunId), [Test10358.hs:5:20-22]), ((Test10358.hs:5:19-32,AnnSemi), [Test10358.hs:6:7]), diff --git a/testsuite/tests/ghc-api/annotations/T10399.stdout b/testsuite/tests/ghc-api/annotations/T10399.stdout index 75d94b3406..b1e5a34d8f 100644 --- a/testsuite/tests/ghc-api/annotations/T10399.stdout +++ b/testsuite/tests/ghc-api/annotations/T10399.stdout @@ -82,12 +82,13 @@ ((Test10399.hs:20:1-25,AnnCloseQ), [Test10399.hs:20:24-25]), ((Test10399.hs:20:1-25,AnnOpen), [Test10399.hs:20:1-3]), ((Test10399.hs:20:1-25,AnnSemi), [Test10399.hs:22:1]), -((Test10399.hs:20:20-22,AnnThIdSplice), [Test10399.hs:20:20-22]), +((Test10399.hs:20:20-22,AnnDollar), [Test10399.hs:20:20]), ((Test10399.hs:22:1-21,AnnEqual), [Test10399.hs:22:19]), ((Test10399.hs:22:1-21,AnnFunId), [Test10399.hs:22:1-3]), ((Test10399.hs:22:1-21,AnnSemi), [Test10399.hs:23:1]), -((Test10399.hs:22:5-17,AnnCloseP), [Test10399.hs:22:17]), -((Test10399.hs:22:5-17,AnnOpenPE), [Test10399.hs:22:5-6]), +((Test10399.hs:22:5-17,AnnDollar), [Test10399.hs:22:5]), +((Test10399.hs:22:6-17,AnnCloseP), [Test10399.hs:22:17]), +((Test10399.hs:22:6-17,AnnOpenP), [Test10399.hs:22:6]), ((Test10399.hs:22:8-15,AnnCloseQ), [Test10399.hs:22:14-15]), ((Test10399.hs:22:8-15,AnnOpen), [Test10399.hs:22:8-10]), ((<no location info>,AnnEofPos), [Test10399.hs:23:1]) diff --git a/testsuite/tests/ghc-api/annotations/T17519.stdout b/testsuite/tests/ghc-api/annotations/T17519.stdout new file mode 100644 index 0000000000..e71dd7f1a0 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/T17519.stdout @@ -0,0 +1,25 @@ +---Unattached Annotation Problems (should be empty list)--- +[] +---Ann before enclosing span problem (should be empty list)--- +[ + +] + +---Annotations----------------------- +-- SrcSpan the annotation is attached to, AnnKeywordId, +-- list of locations the keyword item appears in +[ +((Test17519.hs:1:1,AnnModule), [Test17519.hs:3:1-6]), +((Test17519.hs:1:1,AnnWhere), [Test17519.hs:3:18-22]), +((Test17519.hs:5:1-36,AnnDcolonU), [Test17519.hs:5:21]), +((Test17519.hs:5:1-36,AnnFamily), [Test17519.hs:5:6-11]), +((Test17519.hs:5:1-36,AnnSemi), [Test17519.hs:7:1]), +((Test17519.hs:5:1-36,AnnType), [Test17519.hs:5:1-4]), +((Test17519.hs:5:1-36,AnnWhere), [Test17519.hs:5:38-42]), +((Test17519.hs:5:23-36,AnnForallU), [Test17519.hs:5:23]), +((Test17519.hs:5:23-36,AnnRarrowU), [Test17519.hs:5:27]), +((Test17519.hs:5:29,AnnRarrowU), [Test17519.hs:5:31]), +((Test17519.hs:5:29-36,AnnRarrowU), [Test17519.hs:5:31]), +((Test17519.hs:6:3-18,AnnEqual), [Test17519.hs:6:11]), +((<no location info>,AnnEofPos), [Test17519.hs:7:1]) +] diff --git a/testsuite/tests/ghc-api/annotations/Test17519.hs b/testsuite/tests/ghc-api/annotations/Test17519.hs new file mode 100644 index 0000000000..f705008c51 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/Test17519.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Test17519 where + +type family Proxy2' ∷ ∀ k → k → Type where + Proxy2' = Proxy' diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index f97e107c0a..37b80794cd 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -71,3 +71,5 @@ test('T16279', [extra_files(['Test16279.hs']), ignore_stderr], makefile_test, ['T16279']) test('T17388', [extra_files(['Test17388.hs']), ignore_stderr], makefile_test, ['T17388']) +test('T17519', [extra_files(['Test17519.hs']), + ignore_stderr], makefile_test, ['T17519']) diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs index 8bae838672..3d053a3d7c 100644 --- a/testsuite/tests/ghc-api/annotations/stringSource.hs +++ b/testsuite/tests/ghc-api/annotations/stringSource.hs @@ -80,11 +80,15 @@ testOneFile libdir fileName = do doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])] - doHsExpr (HsCoreAnn _ src ss _) = [("co",[conv (noLoc ss)])] - doHsExpr (HsSCC _ src ss _) = [("sc",[conv (noLoc ss)])] - doHsExpr (HsTickPragma _ src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])] + doHsExpr (HsPragE _ prag _) = doPragE prag doHsExpr _ = [] + doPragE :: HsPragE GhcPs -> [(String,[Located (SourceText,FastString)])] + doPragE (HsPragCore _ src ss) = [("co",[conv (noLoc ss)])] + doPragE (HsPragSCC _ src ss) = [("sc",[conv (noLoc ss)])] + doPragE (HsPragTick _ src (ss,_,_) _ss2) = [("tp",[conv (noLoc ss)])] + doPragE (XHsPragE x) = noExtCon x + conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) showAnns anns = "[\n" ++ (intercalate "\n" diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs index f161e601ce..4b60097a69 100644 --- a/testsuite/tests/ghc-api/annotations/t11430.hs +++ b/testsuite/tests/ghc-api/annotations/t11430.hs @@ -67,7 +67,7 @@ testOneFile libdir fileName = do doRuleDecl (HsRule _ _ _ _ _ _ _) = [] doHsExpr :: HsExpr GhcPs -> [(String,[String])] - doHsExpr (HsTickPragma _ src (_,_,_) ss _) = [("tp",[show ss])] + doHsExpr (HsPragE _ (HsPragTick _ src (_,_,_) ss) _) = [("tp",[show ss])] doHsExpr _ = [] doInline (InlinePragma _ _ _ (ActiveBefore (SourceText ss) _) _) diff --git a/testsuite/tests/ghci/linking/dyn/Makefile b/testsuite/tests/ghci/linking/dyn/Makefile index d4a65a6603..ee345e5560 100644 --- a/testsuite/tests/ghci/linking/dyn/Makefile +++ b/testsuite/tests/ghci/linking/dyn/Makefile @@ -94,7 +94,7 @@ compile_libAS_impl_msvc: .PHONY: T1407 T1407: - cat T1407.script | LD_LIBRARY_PATH=. "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -L"T1407dir" + cat T1407.script | LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -L"T1407dir" .PHONY: T3242 echo ":q" | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -lm diff --git a/testsuite/tests/module/mod183.stderr b/testsuite/tests/module/mod183.stderr index cf7fdf4fa0..5f3c131537 100644 --- a/testsuite/tests/module/mod183.stderr +++ b/testsuite/tests/module/mod183.stderr @@ -1 +1 @@ -mod183.hs:5:26: Multiple occurences of 'qualified' +mod183.hs:5:26: Multiple occurrences of 'qualified' diff --git a/testsuite/tests/module/mod69.stderr b/testsuite/tests/module/mod69.stderr index db7487485e..dea161115e 100644 --- a/testsuite/tests/module/mod69.stderr +++ b/testsuite/tests/module/mod69.stderr @@ -1,4 +1,4 @@ mod69.hs:3:7: error: - Pattern syntax in expression context: x@1 - Did you mean to enable TypeApplications? + @-pattern in expression context: x@1 + Type application syntax requires a space before '@' diff --git a/testsuite/tests/module/mod70.stderr b/testsuite/tests/module/mod70.stderr index 093f166ebd..6e9f854b7a 100644 --- a/testsuite/tests/module/mod70.stderr +++ b/testsuite/tests/module/mod70.stderr @@ -1,2 +1,4 @@ -mod70.hs:3:9: error: Pattern syntax in expression context: ~1 +mod70.hs:3:9: error: + Lazy pattern in expression context: ~1 + Did you mean to add a space after the '~'? diff --git a/testsuite/tests/numeric/should_compile/T16402.hs b/testsuite/tests/numeric/should_compile/T16402.hs new file mode 100644 index 0000000000..c85fe0037b --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T16402.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -ddump-simpl -dhex-word-literals -dsuppress-all -dsuppress-uniques -O2 #-} +{-# LANGUAGE TypeApplications #-} +module T16402 where + +import Data.Word +import Data.Int +import Data.Bits + +smallWord_foo :: Word64 -> Word64 +smallWord_foo x = fromIntegral @Word16 $ fromIntegral (x .&. 0xFFFF) + +smallWord_bar :: Word64 -> Word64 +smallWord_bar x = fromIntegral (fromIntegral x :: Word16) + +smallInt_foo :: Int64 -> Int64 +smallInt_foo x = fromIntegral @Int16 $ fromIntegral (x .&. 0x12FFFF) + +smallInt_bar :: Int64 -> Int64 +smallInt_bar x = fromIntegral (fromIntegral x :: Int16) diff --git a/testsuite/tests/numeric/should_compile/T16402.stderr b/testsuite/tests/numeric/should_compile/T16402.stderr new file mode 100644 index 0000000000..75db843376 --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T16402.stderr @@ -0,0 +1,36 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 34, types: 19, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule3 = TrNameS $trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule2 = "T16402"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule1 = TrNameS $trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$trModule = Module $trModule3 $trModule1 + +-- RHS size: {terms: 7, types: 3, coercions: 0, joins: 0/0} +smallWord_bar + = \ x -> case x of { W64# x# -> W64# (narrow16Word# x#) } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +smallWord_foo = smallWord_bar + +-- RHS size: {terms: 7, types: 3, coercions: 0, joins: 0/0} +smallInt_bar + = \ x -> case x of { I64# x# -> I64# (narrow16Int# x#) } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +smallInt_foo = smallInt_bar + + + diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T index 625951f4d6..a7dc06cf44 100644 --- a/testsuite/tests/numeric/should_compile/all.T +++ b/testsuite/tests/numeric/should_compile/all.T @@ -9,3 +9,4 @@ test('T7881', normal, compile, ['']) # desugaring, so we don't get the warning we expect. test('T8542', omit_ways(['hpc']), compile, ['']) test('T10929', normal, compile, ['']) +test('T16402', [ grep_errmsg(r'and') ], compile, ['']) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr b/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr index b4f29fbfb7..09606e0557 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr @@ -1,6 +1,6 @@ -T11103.hs:13:3: error: +T11103.hs:13:2: error: Ambiguous occurrence ‘Main.foo’ - It could refer to either the field ‘foo’, - defined at T11103.hs:11:16 - or the field ‘foo’, defined at T11103.hs:10:16 + It could refer to + either the field ‘foo’, defined at T11103.hs:11:16 + or the field ‘foo’, defined at T11103.hs:10:16 diff --git a/testsuite/tests/parser/should_compile/Proposal229f_instances.hs b/testsuite/tests/parser/should_compile/Proposal229f_instances.hs new file mode 100644 index 0000000000..2bd5a8ee19 --- /dev/null +++ b/testsuite/tests/parser/should_compile/Proposal229f_instances.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Proposal229f_instances where + +import GHC.Exts +import Data.String +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +instance IsList (Q (TExp String)) where + type Item (Q (TExp String)) = Char + fromList = liftTyped + toList = undefined + +instance IsList (Q Exp) where + type Item (Q Exp) = Char + fromList = lift + toList = undefined + +instance IsString (Q (TExp String)) where + fromString = liftTyped + +instance IsString (Q Exp) where + fromString = lift diff --git a/testsuite/tests/parser/should_compile/T1087.hs b/testsuite/tests/parser/should_compile/T1087.hs new file mode 100644 index 0000000000..9ad85e2b7a --- /dev/null +++ b/testsuite/tests/parser/should_compile/T1087.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE BangPatterns #-} + +module T1087 where + +prefix_1 = let at a !b = False in at 1 2 +prefix_2 = let (.!.) a !b = False in 1 .!. 2 + +infix_tilde_1 = let a `at` ~b = False in at 1 2 +infix_tilde_2 = let a .!. ~b = False in 1 .!. 2 +infix_tilde_3 = let ~a .!. b = False in 1 .!. 2 + +infix_bang_1 = let a .!. !b = False in 1 .!. 2 +infix_bang_2 = let a `at` !b = False in at 1 2 +infix_bang_3 = let !a .!. b = False in 1 .!. 2 diff --git a/testsuite/tests/parser/should_compile/T16619.stderr b/testsuite/tests/parser/should_compile/T16619.stderr new file mode 100644 index 0000000000..b5dfb89623 --- /dev/null +++ b/testsuite/tests/parser/should_compile/T16619.stderr @@ -0,0 +1,3 @@ + +T16619.hs:2:12: warning: + -Wmissing-space-after-bang is deprecated: bang patterns can no longer be written with a space diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index 3d44e22510..91aae139ab 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -145,3 +145,20 @@ test('T16339', normal, compile, ['']) test('T16619', req_th, multimod_compile, ['T16619', '-v0']) test('T504', normal, compile, ['']) test('T515', literate, compile, ['-Wall']) +test('T1087', normal, compile, ['']) +test('proposal-229a', normal, compile, ['']) +test('proposal-229b', normal, compile, ['']) +test('proposal-229d', normal, compile, ['']) +test('proposal-229e', normal, compile, ['']) + +# We omit 'profasm' because it fails with: +# Cannot load -prof objects when GHC is built with -dynamic +# To fix this, either: +# (1) Use -fexternal-interpreter, or +# (2) Build the program twice: once with -dynamic, and then +# with -prof using -osuf to set a different object file suffix. +test('proposal-229f', + [ extra_files(['proposal-229f.hs', 'Proposal229f_instances.hs']), + omit_ways(['profasm', 'profthreaded']) + ], + multimod_compile_and_run, ['proposal-229f.hs', '']) diff --git a/testsuite/tests/parser/should_compile/proposal-229a.hs b/testsuite/tests/parser/should_compile/proposal-229a.hs new file mode 100644 index 0000000000..c773cee3a2 --- /dev/null +++ b/testsuite/tests/parser/should_compile/proposal-229a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE BangPatterns #-} + +module Proposal229a where + +data T a b = a :! b + +(!) :: x -> T a b -> (x, a, b) +~u ! !(!m :! !n) = (u, m, n) diff --git a/testsuite/tests/parser/should_compile/proposal-229b.hs b/testsuite/tests/parser/should_compile/proposal-229b.hs new file mode 100644 index 0000000000..9182623e54 --- /dev/null +++ b/testsuite/tests/parser/should_compile/proposal-229b.hs @@ -0,0 +1,10 @@ +module Proposal229b ((~), (@)) where + +(~) :: a -> b -> (a, b) +x ~ y = (x, y) + +(@) :: a -> b -> (a, b) +x @ y = (x, y) + +r :: ((Bool, Bool), Bool) +r = True ~ False @ True diff --git a/testsuite/tests/parser/should_compile/proposal-229d.hs b/testsuite/tests/parser/should_compile/proposal-229d.hs new file mode 100644 index 0000000000..24a57ca872 --- /dev/null +++ b/testsuite/tests/parser/should_compile/proposal-229d.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE BangPatterns #-} + +module Proposal229d ((!)) where + +(!) :: a -> b -> (a, b) +x ! y = (x,y) -- parsed as an operator even with BangPatterns enabled diff --git a/testsuite/tests/parser/should_compile/proposal-229e.hs b/testsuite/tests/parser/should_compile/proposal-229e.hs new file mode 100644 index 0000000000..d7fc35d38e --- /dev/null +++ b/testsuite/tests/parser/should_compile/proposal-229e.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE BangPatterns #-} + +module Proposal229e ((!), f) where + +(!) :: Maybe a -> a -> (a, a) +f :: a -> a + +-- the preceding '}' is not from a comment, +-- so (!) is tight infix (therefore an operator) +Nothing{}!x = (x, x) + +-- the following '{' opens a multi-line comment, +-- so (!) is loose infix (therefore an operator) +Just a !{-comment-}x = (a, x) + +-- the preceding '}' is closing a multi-line comment, +-- so (!) is prefix (therefore a bang pattern) +f{-comment-}!x = x diff --git a/testsuite/tests/parser/should_compile/proposal-229f.hs b/testsuite/tests/parser/should_compile/proposal-229f.hs new file mode 100644 index 0000000000..75b1341c6f --- /dev/null +++ b/testsuite/tests/parser/should_compile/proposal-229f.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} + +import System.IO +import Proposal229f_instances + +-- Testing that we can parse $[...] and $"..." +main = do + hPutStrLn stderr $['1','2','3'] + hPutStrLn stderr $$['1','2','3'] + hPutStrLn stderr $"123" + hPutStrLn stderr $$"123" diff --git a/testsuite/tests/parser/should_compile/proposal-229f.stderr b/testsuite/tests/parser/should_compile/proposal-229f.stderr new file mode 100644 index 0000000000..310be0621c --- /dev/null +++ b/testsuite/tests/parser/should_compile/proposal-229f.stderr @@ -0,0 +1,4 @@ +123 +123 +123 +123 diff --git a/testsuite/tests/parser/should_fail/T14588.stderr b/testsuite/tests/parser/should_fail/T14588.stderr index cb64103814..2efd9561e8 100644 --- a/testsuite/tests/parser/should_fail/T14588.stderr +++ b/testsuite/tests/parser/should_fail/T14588.stderr @@ -1,4 +1,4 @@ T14588.hs:3:19: error: Illegal bang-pattern (use BangPatterns): - ! x + !x diff --git a/testsuite/tests/parser/should_fail/T16270.stderr b/testsuite/tests/parser/should_fail/T16270.stderr index f4e90e40fc..a74bdeb8f0 100644 --- a/testsuite/tests/parser/should_fail/T16270.stderr +++ b/testsuite/tests/parser/should_fail/T16270.stderr @@ -1,4 +1,7 @@ +T16270.hs:2:12: warning: + -Werror=missing-space-after-bang is deprecated: bang patterns can no longer be written with a space + T16270.hs:7:1: warning: [-Wtabs (in -Wdefault)] Tab character found here, and in five further locations. Please use spaces instead. @@ -46,10 +49,9 @@ T16270.hs:23:10: error: Perhaps you intended to use GADTs or a similar language extension to enable syntax: data T where -T16270.hs:25:12: error: [-Wmissing-space-after-bang (in -Wdefault), -Werror=missing-space-after-bang] - Did you forget to enable BangPatterns? - If you mean to bind (!) then perhaps you want - to add a space after the bang for clarity. +T16270.hs:25:12: error: + Illegal bang-pattern (use BangPatterns): + !i T16270.hs:27:9: error: Multi-way if-expressions need MultiWayIf turned on @@ -57,13 +59,13 @@ T16270.hs:27:9: error: T16270.hs:29:9: error: Multi-way if-expressions need MultiWayIf turned on -T16270.hs:32:6: Illegal lambda-case (use LambdaCase) +T16270.hs:32:6: error: Illegal lambda-case (use LambdaCase) -T16270.hs:35:5: +T16270.hs:35:5: error: Use NumericUnderscores to allow underscores in integer literals -T16270.hs:37:5: - primitive string literal must contain only characters <= '/xFF' +T16270.hs:37:5: error: + primitive string literal must contain only characters <= '\xFF' T16270.hs:43:1: error: parse error (possibly incorrect indentation or mismatched brackets) diff --git a/testsuite/tests/parser/should_fail/T17162.hs b/testsuite/tests/parser/should_fail/T17162.hs new file mode 100644 index 0000000000..6419da7544 --- /dev/null +++ b/testsuite/tests/parser/should_fail/T17162.hs @@ -0,0 +1,13 @@ +-- {-# LANGUAGE NoBangPatterns #-} + +module T17162 where + +charIsRepresentable :: TextEncoding -> Char -> IO Bool +charIsRepresentable !enc c = + withCString enc [c] + (\cstr -> do str <- peekCString enc cstr + case str of + [ch] | ch == c -> pure True + _ -> pure False) + `catch` + \(_ :: IOException) -> pure False diff --git a/testsuite/tests/parser/should_fail/T17162.stderr b/testsuite/tests/parser/should_fail/T17162.stderr new file mode 100644 index 0000000000..d621e08ccc --- /dev/null +++ b/testsuite/tests/parser/should_fail/T17162.stderr @@ -0,0 +1,4 @@ + +T17162.hs:6:21: error: + Illegal bang-pattern (use BangPatterns): + !enc diff --git a/testsuite/tests/parser/should_fail/T3811b.stderr b/testsuite/tests/parser/should_fail/T3811b.stderr index f4e44c603c..65de1d5a75 100644 --- a/testsuite/tests/parser/should_fail/T3811b.stderr +++ b/testsuite/tests/parser/should_fail/T3811b.stderr @@ -1,4 +1,4 @@ T3811b.hs:4:14: error: Cannot parse data constructor in a data/newtype declaration: - ! B + !B diff --git a/testsuite/tests/parser/should_fail/T3811c.stderr b/testsuite/tests/parser/should_fail/T3811c.stderr index 431318e268..52f081bbe6 100644 --- a/testsuite/tests/parser/should_fail/T3811c.stderr +++ b/testsuite/tests/parser/should_fail/T3811c.stderr @@ -1,5 +1,6 @@ -T3811c.hs:6:11: error: - Strictness annotation applied to a compound type. - Did you mean to add parentheses? - !(Show D) +T3811c.hs:6:10: error: + Illegal class instance: ‘!Show D’ + Class instances must be of the form + context => C ty_1 ... ty_n + where ‘C’ is a class diff --git a/testsuite/tests/parser/should_fail/T3811f.stderr b/testsuite/tests/parser/should_fail/T3811f.stderr index 2d31fa86cf..783a89e284 100644 --- a/testsuite/tests/parser/should_fail/T3811f.stderr +++ b/testsuite/tests/parser/should_fail/T3811f.stderr @@ -1,5 +1,3 @@ -T3811f.hs:4:8: error: - Strictness annotation applied to a compound type. - Did you mean to add parentheses? - !(Foo a) +T3811f.hs:4:7: error: + Malformed head of type or class declaration: !Foo a diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T index 2fc7f3d326..c4a7a4f67b 100644 --- a/testsuite/tests/parser/should_fail/all.T +++ b/testsuite/tests/parser/should_fail/all.T @@ -161,3 +161,5 @@ test('patFail006', normal, compile_fail, ['']) test('patFail007', normal, compile_fail, ['']) test('patFail008', normal, compile_fail, ['']) test('patFail009', normal, compile_fail, ['']) +test('T17162', normal, compile_fail, ['']) +test('proposal-229c', normal, compile_fail, ['']) diff --git a/testsuite/tests/parser/should_fail/proposal-229c.hs b/testsuite/tests/parser/should_fail/proposal-229c.hs new file mode 100644 index 0000000000..344311b2a1 --- /dev/null +++ b/testsuite/tests/parser/should_fail/proposal-229c.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE NoBangPatterns #-} + +module Proposal229c (f) where + +-- should recommend to enable BangPatterns instead of parsing as an infix operator +f !x = x diff --git a/testsuite/tests/parser/should_fail/proposal-229c.stderr b/testsuite/tests/parser/should_fail/proposal-229c.stderr new file mode 100644 index 0000000000..965801a3c3 --- /dev/null +++ b/testsuite/tests/parser/should_fail/proposal-229c.stderr @@ -0,0 +1,4 @@ + +proposal-229c.hs:6:3: error: + Illegal bang-pattern (use BangPatterns): + !x diff --git a/testsuite/tests/parser/should_fail/strictnessDataCon_A.stderr b/testsuite/tests/parser/should_fail/strictnessDataCon_A.stderr index c02d2ee974..27e6c709a5 100644 --- a/testsuite/tests/parser/should_fail/strictnessDataCon_A.stderr +++ b/testsuite/tests/parser/should_fail/strictnessDataCon_A.stderr @@ -1,3 +1,3 @@ strictnessDataCon_A.hs:1:27: error: - Strictness annotation cannot appear in this position. + Operator applied to too few arguments: ! diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr index 88fc8d50b9..ad78bc9729 100644 --- a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr @@ -1,23 +1,23 @@ [1 of 2] Compiling Splices ( Splices.hs, Splices.o ) [2 of 2] Compiling SplicesUsed ( SplicesUsed.hs, SplicesUsed.o ) -SplicesUsed.hs:7:16: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:7:15: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Maybe Bool’ • In the type ‘_’ In the type signature: maybeBool :: (_) -SplicesUsed.hs:8:15: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:8:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_a’ standing for ‘_’ Where: ‘_’ is a rigid type variable bound by the inferred type of <expression> :: _ -> _ - at SplicesUsed.hs:8:15-22 + at SplicesUsed.hs:8:14-23 • In an expression type signature: _a -> _a In the expression: id :: _a -> _a In the expression: (id :: _a -> _a) (Just True :: Maybe _) • Relevant bindings include maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) -SplicesUsed.hs:8:27: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:8:26: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Bool’ • In the first argument of ‘Maybe’, namely ‘_’ In the type ‘Maybe _’ @@ -25,7 +25,7 @@ SplicesUsed.hs:8:27: warning: [-Wpartial-type-signatures (in -Wdefault)] • Relevant bindings include maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) -SplicesUsed.hs:10:17: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:10:16: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘(Char, a)’ Where: ‘a’ is a rigid type variable bound by the inferred type of charA :: a -> (Char, a) @@ -33,7 +33,7 @@ SplicesUsed.hs:10:17: warning: [-Wpartial-type-signatures (in -Wdefault)] • In the type ‘a -> (_)’ In the type signature: charA :: a -> (_) -SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘a -> Bool’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] @@ -41,7 +41,7 @@ SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • In the type ‘_ -> _ -> _’ In the type signature: filter' :: (_ -> _ -> _) -SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘[a]’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] @@ -49,7 +49,7 @@ SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • In the type ‘_ -> _ -> _’ In the type signature: filter' :: (_ -> _ -> _) -SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘[a]’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] @@ -57,27 +57,27 @@ SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • In the type ‘_ -> _ -> _’ In the type signature: filter' :: (_ -> _ -> _) -SplicesUsed.hs:16:3: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:16:2: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Eq a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: Eq a => a -> a -> Bool - at SplicesUsed.hs:16:3-10 + at SplicesUsed.hs:16:2-11 • In the type signature: foo :: _ => _ -SplicesUsed.hs:16:3: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:16:2: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘a -> a -> Bool’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: Eq a => a -> a -> Bool - at SplicesUsed.hs:16:3-10 + at SplicesUsed.hs:16:2-11 • In the type signature: foo :: _ => _ -SplicesUsed.hs:18:3: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:18:2: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_a’ standing for ‘Bool’ • In the type signature: bar :: _a -> _b -> (_a, _b) -SplicesUsed.hs:18:3: warning: [-Wpartial-type-signatures (in -Wdefault)] +SplicesUsed.hs:18:2: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_b’ standing for ‘_’ Where: ‘_’ is a rigid type variable bound by the inferred type of bar :: Bool -> _ -> (Bool, _) - at SplicesUsed.hs:18:3-10 + at SplicesUsed.hs:18:2-11 • In the type signature: bar :: _a -> _b -> (_a, _b) diff --git a/testsuite/tests/partial-sigs/should_compile/T12033.hs b/testsuite/tests/partial-sigs/should_compile/T12033.hs index f426b9cdd5..519505fb21 100644 --- a/testsuite/tests/partial-sigs/should_compile/T12033.hs +++ b/testsuite/tests/partial-sigs/should_compile/T12033.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, PartialTypeSignatures #-} --- In #12033 this was called HsakellBug.hs +-- In #12033 this was called HaskellBug.hs module T12033 where tripleStoreToRuleSet :: v -> v diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr index 2426e4cd27..2a83a36cc2 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr @@ -1,5 +1,5 @@ -ExtraConstraintsWildcardInPatternSplice.hs:5:8: error: +ExtraConstraintsWildcardInPatternSplice.hs:5:6: error: • Found type wildcard ‘_’ standing for ‘_’ Where: ‘_’ is a rigid type variable bound by the inferred type of foo :: _ -> () diff --git a/testsuite/tests/perf/should_run/T8763.hs b/testsuite/tests/perf/should_run/T8763.hs index 90c4436ce9..fac6e6302a 100644 --- a/testsuite/tests/perf/should_run/T8763.hs +++ b/testsuite/tests/perf/should_run/T8763.hs @@ -1,7 +1,7 @@ -- | The fusion helper for @enumFromThenTo \@Int@ had multiple --- occurences of @c@, which made the simplifier refuse to inline it. +-- occurrences of @c@, which made the simplifier refuse to inline it. -- The new implementation for @efdtInt{Up,Dn}FB@ only have a single --- occurence of @c@ which the simplifier inlines unconditionally. +-- occurrence of @c@ which the simplifier inlines unconditionally. module Main (main) where import Control.Monad (when, forM_) @@ -12,7 +12,7 @@ nop _ = return () {-# NOINLINE nop #-} -- This is the baseline, using @enumFromTo@ which already had only a --- single occurence of @c@. +-- single occurrence of @c@. f :: Int -> ST s () f n = do diff --git a/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs b/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs index 55e32e5b69..ae4135d203 100644 --- a/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs +++ b/testsuite/tests/plugins/annotation-plugin/SayAnnNames.hs @@ -29,5 +29,5 @@ pass g = do annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] annotationsOn guts bndr = do - anns <- getAnnotations deserializeWithData guts + (_, anns) <- getAnnotations deserializeWithData guts return $ lookupWithDefaultUFM anns [] (varUnique bndr) diff --git a/testsuite/tests/plugins/plugins10.stdout b/testsuite/tests/plugins/plugins10.stdout index f010ce98f8..33f8ff722d 100644 --- a/testsuite/tests/plugins/plugins10.stdout +++ b/testsuite/tests/plugins/plugins10.stdout @@ -13,7 +13,7 @@ interfacePlugin: GHC.Natural parsePlugin(a) typeCheckPlugin (rn) interfacePlugin: Language.Haskell.TH.Lib.Internal -metaPlugin: return [] +metaPlugin: (return []) metaPlugin: quoteExp stringify "x" interfacePlugin: GHC.CString typeCheckPlugin (rn) diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs index 938d23586c..aabc1e5b6c 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs @@ -46,7 +46,7 @@ findNameBndr target b mainPass :: ModGuts -> CoreM ModGuts mainPass guts = do putMsgS "Simple Plugin Pass Run" - anns <- getAnnotations deserializeWithData guts + (_, anns) <- getAnnotations deserializeWithData guts bindsOnlyPass (mapM (changeBind anns Nothing)) guts changeBind :: UniqFM [ReplaceWith] -> Maybe String -> CoreBind -> CoreM CoreBind diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index fce8b7d136..0d7e44b4b6 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -52,6 +52,7 @@ typecheckPlugin [name, "typecheck"] _ tc typecheckPlugin _ _ tc = return tc metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) +metaPlugin' opts (L l (HsPar x e)) = (\e' -> L l (HsPar x e')) <$> metaPlugin' opts e metaPlugin' [name, "meta"] (L _ (HsApp noExt (L l (HsVar _ (L _ id))) e)) | occNameString (getOccName id) == name = return e diff --git a/testsuite/tests/pmcheck/should_compile/CyclicSubst.hs b/testsuite/tests/pmcheck/should_compile/CyclicSubst.hs index 9fe0effe2c..ad351db13a 100644 --- a/testsuite/tests/pmcheck/should_compile/CyclicSubst.hs +++ b/testsuite/tests/pmcheck/should_compile/CyclicSubst.hs @@ -7,7 +7,7 @@ module CyclicSubst where -- | The match is translated to @b | a <- b@, the initial unification variable -- is @a@ (for some reason). VarVar will assign @b :-> a@ in the match of @a@ --- against @b@ (vars occuring in a pattern are flexible). The @PmGrd a b@ is +-- against @b@ (vars occurring in a pattern are flexible). The @PmGrd a b@ is -- desugared as a match of @$pm_x@ against @a@, where @$pm_x :-> b@, which is -- stored as @$pm_x :-> a@ due to the previous solution. Now, VarVar will -- assign @a :-> $pm_x@, causing a cycle. diff --git a/testsuite/tests/pmcheck/should_compile/pmc009.hs b/testsuite/tests/pmcheck/should_compile/pmc009.hs index 08f130de33..95999b2de5 100644 --- a/testsuite/tests/pmcheck/should_compile/pmc009.hs +++ b/testsuite/tests/pmcheck/should_compile/pmc009.hs @@ -2,10 +2,6 @@ module HsUtils where import GHC.Hs.Binds import SrcLoc - --- | We have to be careful to normalise @SrcSpanLess (LHsBind)@ to --- @LHsBindLR l r@ before passing the representative of @unLoc bind@ on to --- @mkOneConFull@, otherwise this triggers a panic in @zipTvSubst@. addPatSynSelector:: LHsBind p -> [a] addPatSynSelector bind | PatSynBind _ _ <- unLoc bind diff --git a/testsuite/tests/pmcheck/should_compile/pmc009.stderr b/testsuite/tests/pmcheck/should_compile/pmc009.stderr index d046b38d0f..9614f2497b 100644 --- a/testsuite/tests/pmcheck/should_compile/pmc009.stderr +++ b/testsuite/tests/pmcheck/should_compile/pmc009.stderr @@ -1,4 +1,4 @@ -pmc009.hs:10:1: warning: [-Wincomplete-patterns (in -Wextra)] +pmc009.hs:6:1: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘addPatSynSelector’: Patterns not matched: L _ _ diff --git a/testsuite/tests/printer/Ppr047.hs b/testsuite/tests/printer/Ppr047.hs index 3ef54c4b38..e7f36850b0 100644 --- a/testsuite/tests/printer/Ppr047.hs +++ b/testsuite/tests/printer/Ppr047.hs @@ -1,4 +1,3 @@ module ExprPragmas where --- Should it be possible to ppr the following annotation? c = {-# GENERATED "foobar" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/testsuite/tests/printer/T13199.stdout b/testsuite/tests/printer/T13199.stdout index 62e56590e0..6ccc1f10f0 100644 --- a/testsuite/tests/printer/T13199.stdout +++ b/testsuite/tests/printer/T13199.stdout @@ -1,48 +1,48 @@ -T13199.hs:(14,3)-(15,6): Splicing declarations +T13199.hs:(14,2)-(15,7): Splicing declarations [d| instance C (Maybe a) (Maybe b) c |] ======> instance C (Maybe a) (Maybe b) c -T13199.hs:21:3-44: Splicing declarations +T13199.hs:21:2-45: Splicing declarations [d| g (a :: (Int -> Int) -> Int) = True |] ======> g (a :: (Int -> Int) -> Int) = True -T13199.hs:24:3-27: Splicing declarations +T13199.hs:24:2-28: Splicing declarations [d| h (id -> x) = True |] ======> h (id -> x) = True -T13199.hs:27:3-37: Splicing declarations +T13199.hs:27:2-38: Splicing declarations [d| f (Just (Just False)) = True |] ======> f (Just (Just False)) = True -T13199.hs:30:3-33: Splicing declarations +T13199.hs:30:2-34: Splicing declarations [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True -T13199.hs:33:3-29: Splicing declarations +T13199.hs:33:2-30: Splicing declarations [d| j B {aa = a} = True |] ======> j B {aa = a} = True -T13199.hs:36:3-28: Splicing declarations +T13199.hs:36:2-29: Splicing declarations [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int) -T13199.hs:38:3-58: Splicing declarations +T13199.hs:38:2-59: Splicing declarations [d| l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } |] ======> l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } -T13199.ppr.hs:11:3-41: Splicing declarations +T13199.ppr.hs:11:2-42: Splicing declarations [d| instance C (Maybe a) (Maybe b) c |] ======> instance C (Maybe a) (Maybe b) c -T13199.ppr.hs:12:3-44: Splicing declarations +T13199.ppr.hs:12:2-45: Splicing declarations [d| g (a :: (Int -> Int) -> Int) = True |] ======> g (a :: (Int -> Int) -> Int) = True -T13199.ppr.hs:13:3-27: Splicing declarations +T13199.ppr.hs:13:2-28: Splicing declarations [d| h (id -> x) = True |] ======> h (id -> x) = True -T13199.ppr.hs:14:3-37: Splicing declarations +T13199.ppr.hs:14:2-38: Splicing declarations [d| f (Just (Just False)) = True |] ======> f (Just (Just False)) = True -T13199.ppr.hs:15:3-33: Splicing declarations +T13199.ppr.hs:15:2-34: Splicing declarations [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True -T13199.ppr.hs:16:3-28: Splicing declarations +T13199.ppr.hs:16:2-29: Splicing declarations [d| j B {aa = a} = True |] ======> j B {aa = a} = True -T13199.ppr.hs:17:3-28: Splicing declarations +T13199.ppr.hs:17:2-29: Splicing declarations [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int) -T13199.ppr.hs:18:3-63: Splicing declarations +T13199.ppr.hs:18:2-64: Splicing declarations [d| l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } |] ======> l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } diff --git a/testsuite/tests/printer/T13550.stdout b/testsuite/tests/printer/T13550.stdout index ff02835912..7f74e48895 100644 --- a/testsuite/tests/printer/T13550.stdout +++ b/testsuite/tests/printer/T13550.stdout @@ -1,4 +1,4 @@ -T13550.hs:(6,3)-(11,6): Splicing declarations +T13550.hs:(6,2)-(11,7): Splicing declarations [d| type family Foo a b data family Bar a b @@ -9,7 +9,7 @@ T13550.hs:(6,3)-(11,6): Splicing declarations type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) data family Bar a b data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) -T13550.ppr.hs:(5,3)-(8,69): Splicing declarations +T13550.ppr.hs:(5,2)-(8,70): Splicing declarations [d| type family Foo a b data family Bar a b diff --git a/testsuite/tests/printer/T13942.stdout b/testsuite/tests/printer/T13942.stdout index 2d0f617074..f40a71bf0f 100644 --- a/testsuite/tests/printer/T13942.stdout +++ b/testsuite/tests/printer/T13942.stdout @@ -1,10 +1,10 @@ -T13942.hs:(5,3)-(7,6): Splicing declarations +T13942.hs:(5,2)-(7,7): Splicing declarations [d| f :: Either Int (Int -> Int) f = undefined |] ======> f :: Either Int (Int -> Int) f = undefined -T13942.ppr.hs:(4,3)-(5,22): Splicing declarations +T13942.ppr.hs:(4,2)-(5,23): Splicing declarations [d| f :: Either Int (Int -> Int) f = undefined |] ======> diff --git a/testsuite/tests/printer/T14289.stdout b/testsuite/tests/printer/T14289.stdout index 3f0754adca..b11a3bf063 100644 --- a/testsuite/tests/printer/T14289.stdout +++ b/testsuite/tests/printer/T14289.stdout @@ -1,4 +1,4 @@ -T14289.hs:10:3-42: Splicing declarations +T14289.hs:10:2-43: Splicing declarations [d| data Foo a = Foo a deriving (C a) |] @@ -6,7 +6,7 @@ T14289.hs:10:3-42: Splicing declarations data Foo a = Foo a deriving (C a) -T14289.ppr.hs:(7,3)-(9,25): Splicing declarations +T14289.ppr.hs:(7,2)-(9,26): Splicing declarations [d| data Foo a = Foo a deriving (C a) |] diff --git a/testsuite/tests/printer/T14289b.stdout b/testsuite/tests/printer/T14289b.stdout index 5d4b248ac3..5c6e0f7474 100644 --- a/testsuite/tests/printer/T14289b.stdout +++ b/testsuite/tests/printer/T14289b.stdout @@ -1,4 +1,4 @@ -T14289b.hs:11:3-46: Splicing declarations +T14289b.hs:11:2-47: Splicing declarations [d| data Foo a = Foo a deriving (y `C` z) |] @@ -6,7 +6,7 @@ T14289b.hs:11:3-46: Splicing declarations data Foo a = Foo a deriving (C y z) -T14289b.ppr.hs:(8,3)-(10,29): Splicing declarations +T14289b.ppr.hs:(8,2)-(10,30): Splicing declarations [d| data Foo a = Foo a deriving (y `C` z) |] diff --git a/testsuite/tests/printer/T14289c.stdout b/testsuite/tests/printer/T14289c.stdout index d200f99a2b..287793b6ea 100644 --- a/testsuite/tests/printer/T14289c.stdout +++ b/testsuite/tests/printer/T14289c.stdout @@ -1,4 +1,4 @@ -T14289c.hs:9:3-44: Splicing declarations +T14289c.hs:9:2-45: Splicing declarations [d| data Foo a = Foo a deriving (a ~ a) |] @@ -6,7 +6,7 @@ T14289c.hs:9:3-44: Splicing declarations data Foo a = Foo a deriving (a ~ a) -T14289c.ppr.hs:(7,3)-(9,27): Splicing declarations +T14289c.ppr.hs:(7,2)-(9,28): Splicing declarations [d| data Foo a = Foo a deriving (a ~ a) |] diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index 3440f57458..83bfd234fc 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -44,7 +44,7 @@ test('Ppr043', [ignore_stderr, req_rts_linker], makefile_test, ['ppr043']) test('Ppr044', ignore_stderr, makefile_test, ['ppr044']) test('Ppr045', ignore_stderr, makefile_test, ['ppr045']) test('Ppr046', ignore_stderr, makefile_test, ['ppr046']) -test('Ppr047', expect_fail, makefile_test, ['ppr047']) +test('Ppr047', ignore_stderr, makefile_test, ['ppr047']) test('Ppr048', ignore_stderr, makefile_test, ['ppr048']) test('T13199', [ignore_stderr, req_rts_linker], makefile_test, ['T13199']) test('T13050p', ignore_stderr, makefile_test, ['T13050p']) diff --git a/testsuite/tests/programs/Makefile-OLD b/testsuite/tests/programs/Makefile-OLD index 0fab32f683..c6d37fe912 100644 --- a/testsuite/tests/programs/Makefile-OLD +++ b/testsuite/tests/programs/Makefile-OLD @@ -29,7 +29,7 @@ NOT_THESE += jeff-bug lennart_array # compiles but doesn't run NOT_THESE += dmgob_native1 dmgob_native2 -# Native library doens't exist +# Native library doesn't exist ifneq "$(HWL_NOFIB_HACK)" "" NOT_THESE += callback zhang_ccall diff --git a/testsuite/tests/programs/andy_cherry/DataTypes.hs b/testsuite/tests/programs/andy_cherry/DataTypes.hs index bcb6cbcf60..01df7f5abd 100644 --- a/testsuite/tests/programs/andy_cherry/DataTypes.hs +++ b/testsuite/tests/programs/andy_cherry/DataTypes.hs @@ -13,7 +13,7 @@ class Presentable a where - userFormat :: a -> String -- in prefered display format + userFormat :: a -> String -- in preferred display format diff --git a/testsuite/tests/programs/andy_cherry/Interp.hs b/testsuite/tests/programs/andy_cherry/Interp.hs index e323dc34f7..9b5f391409 100644 --- a/testsuite/tests/programs/andy_cherry/Interp.hs +++ b/testsuite/tests/programs/andy_cherry/Interp.hs @@ -93,7 +93,7 @@ | head tag == '(' && take 2 (reverse tag) == ":)" && length rest > 1 = getCurrColour `thenP` \ col -> let - invert Black r = r -- because the move has *already* happend + invert Black r = r -- because the move has *already* happened invert _ "0.00" = "0.00" -- don't negate 0 invert _ ('-':r) = r invert _ r = '-':r diff --git a/testsuite/tests/programs/seward-space-leak/Main.lhs b/testsuite/tests/programs/seward-space-leak/Main.lhs index 6c3f9f9d32..fb1527e330 100644 --- a/testsuite/tests/programs/seward-space-leak/Main.lhs +++ b/testsuite/tests/programs/seward-space-leak/Main.lhs @@ -97,7 +97,7 @@ parameter numbering starts at 1). @Call@. Calls to other functions are done with @Call@, which expects the callee to return @Zero@ or @One@, and selects the relevant -branch. The @Tag@s identify calls in the dependancy list. +branch. The @Tag@s identify calls in the dependency list. Although a @Call@ is a glorified @Case@ statement, the only allowed return values are @Zero@ and @One@. Hence the @CDS CDS@ continuations rather than the more comprehensive @(AList Return CDS)@. @@ -166,7 +166,7 @@ as necessary. ToDo: Need to rename call sites? I don't think so. Main CDS evaluator takes \begin{itemize} \item the code store -\item the dependancy list, a list of @Tag@s of calls which are +\item the dependency list, a list of @Tag@s of calls which are currently in progress \item the current arguments \item the CDS fragment currently being worked on diff --git a/testsuite/tests/rename/should_fail/T12879.stderr b/testsuite/tests/rename/should_fail/T12879.stderr index 1b3559c255..0c6b7f36f5 100644 --- a/testsuite/tests/rename/should_fail/T12879.stderr +++ b/testsuite/tests/rename/should_fail/T12879.stderr @@ -1,4 +1,4 @@ T12879.hs:4:7: error: - Pattern syntax in expression context: x@x + @-pattern in expression context: x@x Type application syntax requires a space before '@' diff --git a/testsuite/tests/rename/should_fail/rnfail016.stderr b/testsuite/tests/rename/should_fail/rnfail016.stderr index 47436132f2..6ed450ce0b 100644 --- a/testsuite/tests/rename/should_fail/rnfail016.stderr +++ b/testsuite/tests/rename/should_fail/rnfail016.stderr @@ -1,4 +1,4 @@ rnfail016.hs:6:7: error: - Pattern syntax in expression context: x@x - Did you mean to enable TypeApplications? + @-pattern in expression context: x@x + Type application syntax requires a space before '@' diff --git a/testsuite/tests/rename/should_fail/rnfail016a.stderr b/testsuite/tests/rename/should_fail/rnfail016a.stderr index 3a59ee7478..544cf58cac 100644 --- a/testsuite/tests/rename/should_fail/rnfail016a.stderr +++ b/testsuite/tests/rename/should_fail/rnfail016a.stderr @@ -1,2 +1,2 @@ -rnfail016a.hs:6:7: error: Pattern syntax in expression context: ~x +rnfail016a.hs:6:7: error: parse error on input ‘~’ diff --git a/testsuite/tests/rename/should_fail/rnfail051.stderr b/testsuite/tests/rename/should_fail/rnfail051.stderr index 9c45a6168b..c1f4f43a2f 100644 --- a/testsuite/tests/rename/should_fail/rnfail051.stderr +++ b/testsuite/tests/rename/should_fail/rnfail051.stderr @@ -1,3 +1,3 @@ rnfail051.hs:7:17: error: - Pattern syntax in expression context: _ -> putStrLn "_" + View pattern in expression context: _ -> putStrLn "_" diff --git a/testsuite/tests/roles/should_compile/T16718.stderr b/testsuite/tests/roles/should_compile/T16718.stderr index 8e2530ef31..18c1bee5d1 100644 --- a/testsuite/tests/roles/should_compile/T16718.stderr +++ b/testsuite/tests/roles/should_compile/T16718.stderr @@ -1,4 +1,4 @@ -T16718.hs:(5,3)-(7,6): Splicing declarations +T16718.hs:(5,2)-(7,7): Splicing declarations [d| type role P phantom data P a |] diff --git a/testsuite/tests/runghc/T17171a.stderr b/testsuite/tests/runghc/T17171a.stderr index 5079cf4075..bf11f1e1f4 100644 --- a/testsuite/tests/runghc/T17171a.stderr +++ b/testsuite/tests/runghc/T17171a.stderr @@ -1,5 +1 @@ -Main.hs:1:1: error: The IO action ‘main’ is not exported by module ‘Main’ - | -1 | module Main () where - | ^ diff --git a/testsuite/tests/runghc/all.T b/testsuite/tests/runghc/all.T index 33174d04dc..4503e8c996 100644 --- a/testsuite/tests/runghc/all.T +++ b/testsuite/tests/runghc/all.T @@ -6,8 +6,11 @@ test('T11247', [req_interp, expect_broken(11247)], makefile_test, []) test('T6132', [when(opsys('darwin'), expect_broken(6132))], compile, ['']) -test('T17171a', [req_interp, expect_fail], makefile_test, []) -test('T17171b', req_interp, makefile_test, []) +test('T17171a', + [req_interp, exit_code(2), ignore_stdout, grep_errmsg(r'main')], + run_command, ['$MAKE -s --no-print-directory T17171a']) +test('T17171b', req_interp, run_command, + ['$MAKE -s --no-print-directory T17171b']) test('T-signals-child', [ when(opsys('mingw32'), skip), req_interp diff --git a/testsuite/tests/safeHaskell/check/Check06.hs b/testsuite/tests/safeHaskell/check/Check06.hs index a4debfc2cb..99649fa079 100644 --- a/testsuite/tests/safeHaskell/check/Check06.hs +++ b/testsuite/tests/safeHaskell/check/Check06.hs @@ -1,7 +1,7 @@ {-# LANGUAGE Trustworthy, NoImplicitPrelude #-} {-# OPTIONS_GHC -fpackage-trust #-} --- make sure importing a safe-infered module brings in the +-- make sure importing a safe-inferred module brings in the -- pkg trust requirements correctly. module Check06 ( main' ) where diff --git a/testsuite/tests/safeHaskell/check/Check06_A.hs b/testsuite/tests/safeHaskell/check/Check06_A.hs index 9c9d92ba24..4cda329fec 100644 --- a/testsuite/tests/safeHaskell/check/Check06_A.hs +++ b/testsuite/tests/safeHaskell/check/Check06_A.hs @@ -1,4 +1,4 @@ --- safe infered, with requirement base is trusted +-- safe inferred, with requirement base is trusted module Check06_A where mainM :: Int -> Int diff --git a/testsuite/tests/safeHaskell/check/Check07_A.hs b/testsuite/tests/safeHaskell/check/Check07_A.hs index 5b38c6a07b..efc58e0bfe 100644 --- a/testsuite/tests/safeHaskell/check/Check07_A.hs +++ b/testsuite/tests/safeHaskell/check/Check07_A.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} --- safe infered, with no pkg trust reqs +-- safe inferred, with no pkg trust reqs module Check07_A where a :: a -> a diff --git a/testsuite/tests/safeHaskell/check/Check07_B.hs b/testsuite/tests/safeHaskell/check/Check07_B.hs index 4a2003f9a9..5085cc18ab 100644 --- a/testsuite/tests/safeHaskell/check/Check07_B.hs +++ b/testsuite/tests/safeHaskell/check/Check07_B.hs @@ -1,4 +1,4 @@ --- safe infered, with requirement base is trusted +-- safe inferred, with requirement base is trusted module Check07_B where import Prelude diff --git a/testsuite/tests/safeHaskell/check/Check08_A.hs b/testsuite/tests/safeHaskell/check/Check08_A.hs index c888a59b71..4438a34e09 100644 --- a/testsuite/tests/safeHaskell/check/Check08_A.hs +++ b/testsuite/tests/safeHaskell/check/Check08_A.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} --- safe infered, with no pkg trust reqs +-- safe inferred, with no pkg trust reqs module Check08_A where a :: a -> a diff --git a/testsuite/tests/safeHaskell/check/Check08_B.hs b/testsuite/tests/safeHaskell/check/Check08_B.hs index 41feab5eae..42d01f2b33 100644 --- a/testsuite/tests/safeHaskell/check/Check08_B.hs +++ b/testsuite/tests/safeHaskell/check/Check08_B.hs @@ -1,4 +1,4 @@ --- safe infered, with requirement base is trusted +-- safe inferred, with requirement base is trusted module Check08_B where import Prelude diff --git a/testsuite/tests/safeHaskell/check/all.T b/testsuite/tests/safeHaskell/check/all.T index 47e875d3be..8cf37d3b43 100644 --- a/testsuite/tests/safeHaskell/check/all.T +++ b/testsuite/tests/safeHaskell/check/all.T @@ -41,7 +41,7 @@ test('Check04', normal, multi_compile, ['Check04', [ # Check -fpackage-trust with no safe haskell flag is an error test('Check05', normal, compile, ['']) -# Check safe-infered modules have correct pkg trust requirements +# Check safe-inferred modules have correct pkg trust requirements test('Check06', [], multimod_compile_fail, ['Check06', '']) # Check selective safe imports bring in correct pkg trust requirements diff --git a/testsuite/tests/safeHaskell/check/pkg01/M_SafePkg5.hs b/testsuite/tests/safeHaskell/check/pkg01/M_SafePkg5.hs index a4b7390352..75bde26b4e 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/M_SafePkg5.hs +++ b/testsuite/tests/safeHaskell/check/pkg01/M_SafePkg5.hs @@ -1,6 +1,6 @@ -- safe inference -- same module as M_SafePkg4 which compiles with -XSafe. --- Want to make sure compiles fine and is infered safe and +-- Want to make sure compiles fine and is inferred safe and -- also picks up corrected pkg trust requirements. module M_SafePkg5 where diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags21.hs b/testsuite/tests/safeHaskell/flags/SafeFlags21.hs index c7e8b0d87a..5169a03583 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags21.hs +++ b/testsuite/tests/safeHaskell/flags/SafeFlags21.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fwarn-unsafe #-} -- | Basic test to see if Safe warning flags compile --- Warn if module is infered unsafe +-- Warn if module is inferred unsafe -- In this test the warning _shouldn't_ fire module SafeFlags21 where diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags22.hs b/testsuite/tests/safeHaskell/flags/SafeFlags22.hs index 0b94cff91c..3d5d8dc1af 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags22.hs +++ b/testsuite/tests/safeHaskell/flags/SafeFlags22.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fwarn-unsafe #-} -- | Basic test to see if Safe warning flags compile --- Warn if module is infered unsafe +-- Warn if module is inferred unsafe -- In this test the warning _should_ fire module SafeFlags22 where diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags23.hs b/testsuite/tests/safeHaskell/flags/SafeFlags23.hs index 87f7b2dc5d..b3180bc1e1 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags23.hs +++ b/testsuite/tests/safeHaskell/flags/SafeFlags23.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fwarn-unsafe -Werror #-} -- | Basic test to see if Safe warning flags compile --- Warn if module is infered unsafe +-- Warn if module is inferred unsafe -- In this test the warning _should_ fire and cause a compile fail module SafeFlags22 where diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags24.hs b/testsuite/tests/safeHaskell/flags/SafeFlags24.hs index 928d322e3c..ab63880f80 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags24.hs +++ b/testsuite/tests/safeHaskell/flags/SafeFlags24.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fwarn-safe #-} -- | Basic test to see if Safe warning flags compile --- Warn if module is infered safe +-- Warn if module is inferred safe -- In this test the warning _shouldn't_ fire module SafeFlags23 where diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags25.hs b/testsuite/tests/safeHaskell/flags/SafeFlags25.hs index c97fa885d1..7d650d6a72 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags25.hs +++ b/testsuite/tests/safeHaskell/flags/SafeFlags25.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fwarn-safe #-} -- | Basic test to see if Safe warning flags compile --- Warn if module is infered safe +-- Warn if module is inferred safe -- In this test the warning _should_ fire module SafeFlags25 where diff --git a/testsuite/tests/safeHaskell/flags/SafeFlags26.hs b/testsuite/tests/safeHaskell/flags/SafeFlags26.hs index 0767448bca..45b65f3d9e 100644 --- a/testsuite/tests/safeHaskell/flags/SafeFlags26.hs +++ b/testsuite/tests/safeHaskell/flags/SafeFlags26.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fwarn-safe -Werror #-} -- | Basic test to see if Safe warning flags compile --- Warn if module is infered safe +-- Warn if module is inferred safe -- In this test the warning _should_ fire and cause a compile fail module SafeFlags26 where diff --git a/testsuite/tests/safeHaskell/safeInfered/all.T b/testsuite/tests/safeHaskell/safeInfered/all.T index be38d8ff12..e9b03b5458 100644 --- a/testsuite/tests/safeHaskell/safeInfered/all.T +++ b/testsuite/tests/safeHaskell/safeInfered/all.T @@ -7,14 +7,14 @@ def f( name, opts ): setTestOpts(f) -# Tests that should compile fine as they should be infered safe +# Tests that should compile fine as they should be inferred safe test('SafeInfered01', [], multimod_compile, ['SafeInfered01', '']) test('SafeInfered02', [], multimod_compile, ['SafeInfered02', '']) test('SafeInfered03', [], multimod_compile, ['SafeInfered03', '']) test('SafeInfered04', [], multimod_compile, ['SafeInfered04', '']) test('SafeInfered05', [], multimod_compile, ['SafeInfered05', '']) -# Tests that should fail to compile as they should be infered unsafe +# Tests that should fail to compile as they should be inferred unsafe test('UnsafeInfered01', [], multimod_compile_fail, ['UnsafeInfered01', '']) test('UnsafeInfered02', [], multimod_compile_fail, ['UnsafeInfered02', '']) test('UnsafeInfered03', [], multimod_compile_fail, ['UnsafeInfered03', '']) diff --git a/testsuite/tests/saks/should_compile/T17164.stderr b/testsuite/tests/saks/should_compile/T17164.stderr index 5b1fdbf0fc..87bcb9b3ff 100644 --- a/testsuite/tests/saks/should_compile/T17164.stderr +++ b/testsuite/tests/saks/should_compile/T17164.stderr @@ -1,4 +1,4 @@ -T17164.hs:(12,3)-(14,6): Splicing declarations +T17164.hs:(12,2)-(14,7): Splicing declarations [d| type T :: forall k -> k -> Type type family T :: forall k -> k -> Type |] diff --git a/testsuite/tests/saks/should_compile/saks027.stderr b/testsuite/tests/saks/should_compile/saks027.stderr index 730b1cfde6..8a1b5d8057 100644 --- a/testsuite/tests/saks/should_compile/saks027.stderr +++ b/testsuite/tests/saks/should_compile/saks027.stderr @@ -1,4 +1,4 @@ -saks027.hs:(8,3)-(10,6): Splicing declarations +saks027.hs:(8,2)-(10,7): Splicing declarations [d| type U :: Type data U = MkU |] diff --git a/testsuite/tests/th/ClosedFam1TH.stderr b/testsuite/tests/th/ClosedFam1TH.stderr index 8db375413a..0ffa3428e7 100644 --- a/testsuite/tests/th/ClosedFam1TH.stderr +++ b/testsuite/tests/th/ClosedFam1TH.stderr @@ -1,5 +1,5 @@ -ClosedFam1TH.hs:7:3: warning: +ClosedFam1TH.hs:7:2: warning: type family Foo_0 a_1 (b_2 :: k_3) where Foo_0 GHC.Types.Int GHC.Types.Bool = GHC.Types.Int Foo_0 a_4 GHC.Maybe.Maybe = GHC.Types.Bool diff --git a/testsuite/tests/th/T10279.stderr b/testsuite/tests/th/T10279.stderr index d5f7052d05..e71f28795b 100644 --- a/testsuite/tests/th/T10279.stderr +++ b/testsuite/tests/th/T10279.stderr @@ -1,5 +1,5 @@ -T10279.hs:10:10: error: +T10279.hs:10:9: error: • Failed to load interface for ‘A’ no unit id matching ‘rts-1.0’ was found (This unit ID looks like the source package ID; diff --git a/testsuite/tests/th/T10598_TH.stderr b/testsuite/tests/th/T10598_TH.stderr index 64714211fd..d6c08b0a43 100644 --- a/testsuite/tests/th/T10598_TH.stderr +++ b/testsuite/tests/th/T10598_TH.stderr @@ -1,13 +1,10 @@ -T10598_TH.hs:(27,3)-(42,50): Splicing declarations +T10598_TH.hs:(27,2)-(42,51): Splicing declarations do fooDataName <- newName "Foo" mkFooConName <- newName "MkFoo" let fooType = conT fooDataName sequence [newtypeD - (cxt []) - fooDataName - [] - Nothing + (cxt []) fooDataName [] Nothing (normalC mkFooConName [bangType @@ -16,18 +13,15 @@ T10598_TH.hs:(27,3)-(42,50): Splicing declarations derivClause (Just AnyclassStrategy) [[t| C |]], derivClause (Just NewtypeStrategy) [[t| Read |]]], standaloneDerivWithStrategyD - (Just StockStrategy) - (cxt []) + (Just StockStrategy) (cxt []) [t| Ord $(fooType) |] pending(rn) [<splice, fooType>], standaloneDerivWithStrategyD - (Just AnyclassStrategy) - (cxt []) + (Just AnyclassStrategy) (cxt []) [t| D $(fooType) |] pending(rn) [<splice, fooType>], standaloneDerivWithStrategyD - (Just NewtypeStrategy) - (cxt []) + (Just NewtypeStrategy) (cxt []) [t| Show $(fooType) |] pending(rn) [<splice, fooType>]] ======> diff --git a/testsuite/tests/th/T10603.stderr b/testsuite/tests/th/T10603.stderr index c294e74226..3de6cb057b 100644 --- a/testsuite/tests/th/T10603.stderr +++ b/testsuite/tests/th/T10603.stderr @@ -1,4 +1,4 @@ -T10603.hs:5:18-68: Splicing expression +T10603.hs:5:17-69: Splicing expression [| case Just 'a' of { Just a -> Just ((\ x -> x) a) } |] ======> case Just 'a' of { Just a -> Just ((\ x -> x) a) } diff --git a/testsuite/tests/th/T10638.stderr b/testsuite/tests/th/T10638.stderr index cc4946a074..582190e688 100644 --- a/testsuite/tests/th/T10638.stderr +++ b/testsuite/tests/th/T10638.stderr @@ -1,5 +1,5 @@ -T10638.hs:26:11: - ‘static test2’ is not a valid C identifier - When checking declaration: - foreign import prim safe "static test2" cmm_test2 :: Int# -> Int# +T10638.hs:26:10: error: + • ‘static test2’ is not a valid C identifier + • When checking declaration: + foreign import prim safe "static test2" cmm_test2 :: Int# -> Int# diff --git a/testsuite/tests/th/T10796b.stderr b/testsuite/tests/th/T10796b.stderr index 2491a8c259..7c7b89171b 100644 --- a/testsuite/tests/th/T10796b.stderr +++ b/testsuite/tests/th/T10796b.stderr @@ -1,5 +1,5 @@ -T10796b.hs:8:17: error: +T10796b.hs:8:16: error: • Can't construct a pattern from name Data.Set.Internal.fromList • In the untyped splice: $(dataToPatQ (const Nothing) (fromList "test")) diff --git a/testsuite/tests/th/T10810.stderr b/testsuite/tests/th/T10810.stderr index c960fe1941..83e9434cb1 100644 --- a/testsuite/tests/th/T10810.stderr +++ b/testsuite/tests/th/T10810.stderr @@ -1,2 +1,2 @@ -T10810.hs:6:3-24: Splicing declarations +T10810.hs:6:2-25: Splicing declarations [d| data Foo = (:!) |] ======> data Foo = (:!) diff --git a/testsuite/tests/th/T10828a.stderr b/testsuite/tests/th/T10828a.stderr index 9c05b83190..6f2b16465a 100644 --- a/testsuite/tests/th/T10828a.stderr +++ b/testsuite/tests/th/T10828a.stderr @@ -1,4 +1,4 @@ -T10828a.hs:9:4: +T10828a.hs:9:2: error: Kind signatures are only allowed on GADTs When splicing a TH declaration: data T a :: * = MkT a a diff --git a/testsuite/tests/th/T10828b.stderr b/testsuite/tests/th/T10828b.stderr index bbc57dd3ab..e5f36906f7 100644 --- a/testsuite/tests/th/T10828b.stderr +++ b/testsuite/tests/th/T10828b.stderr @@ -1,5 +1,5 @@ -T10828b.hs:9:4: +T10828b.hs:9:2: error: Cannot mix GADT constructors with Haskell 98 constructors When splicing a TH declaration: data T a :: * diff --git a/testsuite/tests/th/T11452.stderr b/testsuite/tests/th/T11452.stderr index e4f1cc604d..0649997ff1 100644 --- a/testsuite/tests/th/T11452.stderr +++ b/testsuite/tests/th/T11452.stderr @@ -1,5 +1,5 @@ -T11452.hs:6:14: error: +T11452.hs:6:12: error: • Illegal polytype: (forall a. a -> a) -> () The type of a Typed Template Haskell expression must not have any quantification. • In the Template Haskell splice $$([|| \ _ -> () ||]) diff --git a/testsuite/tests/th/T12045TH1.stderr b/testsuite/tests/th/T12045TH1.stderr index aede24c7a0..2b856434d5 100644 --- a/testsuite/tests/th/T12045TH1.stderr +++ b/testsuite/tests/th/T12045TH1.stderr @@ -1,4 +1,4 @@ -T12045TH1.hs:(8,3)-(10,52): Splicing declarations +T12045TH1.hs:(8,2)-(10,53): Splicing declarations [d| type family F (a :: k) :: Type where F @Type Int = Bool F @(Type -> Type) Maybe = Char |] @@ -6,13 +6,13 @@ T12045TH1.hs:(8,3)-(10,52): Splicing declarations type family F (a :: k) :: Type where F @Type Int = Bool F @(Type -> Type) Maybe = Char -T12045TH1.hs:13:3-31: Splicing declarations +T12045TH1.hs:13:2-32: Splicing declarations [d| data family D (a :: k) |] ======> data family D (a :: k) -T12045TH1.hs:15:3-40: Splicing declarations +T12045TH1.hs:15:2-41: Splicing declarations [d| data instance D @Type a = DBool |] ======> data instance D @Type a = DBool -T12045TH1.hs:17:3-50: Splicing declarations +T12045TH1.hs:17:2-51: Splicing declarations [d| data instance D @(Type -> Type) b = DChar |] ======> data instance D @(Type -> Type) b = DChar diff --git a/testsuite/tests/th/T12387.stderr b/testsuite/tests/th/T12387.stderr index 81c2eef5f7..53b8550cdd 100644 --- a/testsuite/tests/th/T12387.stderr +++ b/testsuite/tests/th/T12387.stderr @@ -1,4 +1,4 @@ -T12387.hs:8:3: error: +T12387.hs:8:2: error: • Class ‘Eq’ does not have a method ‘compare’ • In the instance declaration for ‘Eq Foo’ diff --git a/testsuite/tests/th/T12411.stderr b/testsuite/tests/th/T12411.stderr index 1f344323bd..65f77d0723 100644 --- a/testsuite/tests/th/T12411.stderr +++ b/testsuite/tests/th/T12411.stderr @@ -1,4 +1,8 @@ -T12411.hs:4:1: error: - Pattern syntax in expression context: pure@Q - Did you mean to enable TypeApplications? +T12411.hs:4:6: error: + Variable not in scope: + (@) + :: (a0 -> f0 a0) -> t0 -> Language.Haskell.TH.Lib.Internal.DecsQ + +T12411.hs:4:7: error: + Data constructor not in scope: Q :: [a1] -> t0 diff --git a/testsuite/tests/th/T12478_4.stderr b/testsuite/tests/th/T12478_4.stderr index 6a68b3d15a..2cc0d1142d 100644 --- a/testsuite/tests/th/T12478_4.stderr +++ b/testsuite/tests/th/T12478_4.stderr @@ -1,5 +1,5 @@ -T12478_4.hs:7:8: error: +T12478_4.hs:7:7: error: • Illegal sum arity: 1 Sums must have an arity of at least 2 When splicing a TH type: (# #) GHC.Tuple.() diff --git a/testsuite/tests/th/T12530.stderr b/testsuite/tests/th/T12530.stderr index 0ba15360ac..7398b32df1 100644 --- a/testsuite/tests/th/T12530.stderr +++ b/testsuite/tests/th/T12530.stderr @@ -1,4 +1,4 @@ -T12530.hs:(8,3)-(15,6): Splicing declarations +T12530.hs:(8,2)-(15,7): Splicing declarations [d| f :: Maybe Int -> Maybe Int f = id @(Maybe Int) g :: forall a. a diff --git a/testsuite/tests/th/T13776.stderr b/testsuite/tests/th/T13776.stderr index 485dc64a28..debcc0bbcd 100644 --- a/testsuite/tests/th/T13776.stderr +++ b/testsuite/tests/th/T13776.stderr @@ -1,14 +1,12 @@ -T13776.hs:10:16-42: Splicing type +T13776.hs:10:15-43: Splicing type conT ''[] `appT` conT ''Int ======> [] Int -T13776.hs:7:16-61: Splicing type +T13776.hs:7:15-62: Splicing type conT ''(,) `appT` conT ''Int `appT` conT ''Int ======> (,) Int Int -T13776.hs:14:16-74: Splicing expression +T13776.hs:14:15-75: Splicing expression conE '(,) `appE` litE (integerL 1) `appE` litE (integerL 1) ======> ((,) 1) 1 -T13776.hs:17:16-23: Splicing expression - conE '[] ======> [] -T13776.hs:20:14-61: Splicing pattern +T13776.hs:17:15-24: Splicing expression conE '[] ======> [] +T13776.hs:20:13-62: Splicing pattern conP '(,) [litP (integerL 1), litP (integerL 1)] ======> (,) 1 1 -T13776.hs:23:14-24: Splicing pattern - conP '[] [] ======> [] +T13776.hs:23:13-25: Splicing pattern conP '[] [] ======> [] diff --git a/testsuite/tests/th/T13837.stderr b/testsuite/tests/th/T13837.stderr index 53700b5a7a..7bb6587ded 100644 --- a/testsuite/tests/th/T13837.stderr +++ b/testsuite/tests/th/T13837.stderr @@ -1,5 +1,5 @@ -T13837.hs:9:5: error: +T13837.hs:9:4: error: • The exact Name ‘Fam’ is not in scope Probable cause: you used a unique Template Haskell name (NameU), perhaps via newName, but did not bind it diff --git a/testsuite/tests/th/T13856.stderr b/testsuite/tests/th/T13856.stderr index 141b7a2f69..1d54574253 100644 --- a/testsuite/tests/th/T13856.stderr +++ b/testsuite/tests/th/T13856.stderr @@ -1 +1 @@ -T13856.hs:8:7-22: Splicing expression lamE [] [| 42 |] ======> 42 +T13856.hs:8:6-23: Splicing expression lamE [] [| 42 |] ======> 42 diff --git a/testsuite/tests/th/T13968.stderr b/testsuite/tests/th/T13968.stderr index 2850dae0c5..420e3c6432 100644 --- a/testsuite/tests/th/T13968.stderr +++ b/testsuite/tests/th/T13968.stderr @@ -1,3 +1,3 @@ -T13968.hs:6:3: error: +T13968.hs:6:2: error: Cannot redefine a Name retrieved by a Template Haskell quote: succ diff --git a/testsuite/tests/th/T14204.stderr b/testsuite/tests/th/T14204.stderr index 90150e2050..5a8f57aa58 100644 --- a/testsuite/tests/th/T14204.stderr +++ b/testsuite/tests/th/T14204.stderr @@ -1,5 +1,5 @@ -T14204.hs:8:35: error: +T14204.hs:8:34: error: • Illegal static expression: static "wat" Use StaticPointers to enable this extension • In the untyped splice: $(pure (StaticE (LitE (StringL "wat")))) diff --git a/testsuite/tests/th/T14646.stderr b/testsuite/tests/th/T14646.stderr index 869cf6fd01..a8a82b1426 100644 --- a/testsuite/tests/th/T14646.stderr +++ b/testsuite/tests/th/T14646.stderr @@ -1,4 +1,4 @@ -T14646.hs:(5,3)-(6,24): Splicing declarations +T14646.hs:(5,2)-(6,25): Splicing declarations [d| f :: (forall a. a) -> Int f _ = undefined |] ======> diff --git a/testsuite/tests/th/T14681.stderr b/testsuite/tests/th/T14681.stderr index debb18dee5..0a23fd1473 100644 --- a/testsuite/tests/th/T14681.stderr +++ b/testsuite/tests/th/T14681.stderr @@ -1,6 +1,6 @@ -T14681.hs:7:3-31: Splicing declarations +T14681.hs:7:2-32: Splicing declarations [d| f = \ (Identity x) -> x |] ======> f = \ (Identity x) -> x -T14681.hs:(8,3)-(9,62): Splicing declarations +T14681.hs:(8,2)-(9,63): Splicing declarations [d| g = $(pure $ VarE '(+) `AppE` LitE (IntegerL (- 1)) `AppE` (LitE (IntegerL (- 1)))) |] diff --git a/testsuite/tests/th/T14817.stderr b/testsuite/tests/th/T14817.stderr index 034c9e3bed..524711c988 100644 --- a/testsuite/tests/th/T14817.stderr +++ b/testsuite/tests/th/T14817.stderr @@ -1,4 +1,4 @@ -T14817.hs:(7,3)-(8,34): Splicing declarations +T14817.hs:(7,2)-(8,35): Splicing declarations [d| data family Foo :: Type data instance Foo :: Type |] diff --git a/testsuite/tests/th/T14869.stderr b/testsuite/tests/th/T14869.stderr index a2776b8cc8..5361f697e3 100644 --- a/testsuite/tests/th/T14869.stderr +++ b/testsuite/tests/th/T14869.stderr @@ -1,17 +1,17 @@ -T14869.hs:19:3-9: Splicing declarations pure [] ======> -T14869.hs:22:10-42: Splicing expression +T14869.hs:19:2-10: Splicing declarations pure [] ======> +T14869.hs:22:9-43: Splicing expression reify ''Foo1 >>= stringE . pprint ======> "type family T14869.Foo1 :: *" -T14869.hs:23:10-42: Splicing expression +T14869.hs:23:9-43: Splicing expression reify ''Foo2 >>= stringE . pprint ======> "type family T14869.Foo2 :: Constraint" -T14869.hs:24:10-42: Splicing expression +T14869.hs:24:9-43: Splicing expression reify ''Foo3 >>= stringE . pprint ======> "type family T14869.Foo3 :: T14869.MyConstraint" -T14869.hs:25:10-42: Splicing expression +T14869.hs:25:9-43: Splicing expression reify ''Foo4 >>= stringE . pprint ======> "type family T14869.Foo4 :: *" diff --git a/testsuite/tests/th/T14875.stderr b/testsuite/tests/th/T14875.stderr index 09374f243d..e5e54b9558 100644 --- a/testsuite/tests/th/T14875.stderr +++ b/testsuite/tests/th/T14875.stderr @@ -1,4 +1,4 @@ -T14875.hs:(5,3)-(14,6): Splicing declarations +T14875.hs:(5,2)-(14,7): Splicing declarations [d| f :: Bool -> Bool f x = case x of diff --git a/testsuite/tests/th/T14888.stderr b/testsuite/tests/th/T14888.stderr index e6d63254e7..4df1e669dc 100644 --- a/testsuite/tests/th/T14888.stderr +++ b/testsuite/tests/th/T14888.stderr @@ -1,7 +1,7 @@ -T14888.hs:6:10-30: Splicing type +T14888.hs:6:9-31: Splicing type [t| (->) Bool Bool |] ======> Bool -> Bool -T14888.hs:15:3-11: Splicing declarations return [] ======> -T14888.hs:18:23-59: Splicing expression +T14888.hs:15:2-12: Splicing declarations return [] ======> +T14888.hs:18:22-60: Splicing expression reify ''Functor' >>= stringE . pprint ======> "class T14888.Functor' (f_0 :: * -> *) diff --git a/testsuite/tests/th/T15243.stderr b/testsuite/tests/th/T15243.stderr index 4e50186c1f..4cf78cacd6 100644 --- a/testsuite/tests/th/T15243.stderr +++ b/testsuite/tests/th/T15243.stderr @@ -1,12 +1,12 @@ -T15243.hs:(10,3)-(15,6): Splicing declarations +T15243.hs:(10,2)-(15,7): Splicing declarations [d| type family F (a :: k) :: k where - F 'Unit = 'Unit - F '(,) = '(,) + F 'Unit = 'Unit + F '(,) = '(,) F '[] = '[] - F '(:) = '(:) |] + F '(:) = '(:) |] ======> type family F (a :: k) :: k where - F 'Unit = 'Unit - F '(,) = '(,) + F 'Unit = 'Unit + F '(,) = '(,) F '[] = '[] - F '(:) = '(:) + F '(:) = '(:) diff --git a/testsuite/tests/th/T15270A.stderr b/testsuite/tests/th/T15270A.stderr index 2eb67f60ba..ba43e4dae8 100644 --- a/testsuite/tests/th/T15270A.stderr +++ b/testsuite/tests/th/T15270A.stderr @@ -1,5 +1,5 @@ -T15270A.hs:8:7: - Illegal data constructor name: ‘id’ +T15270A.hs:8:6: error: + • Illegal data constructor name: ‘id’ When splicing a TH expression: GHC.Base.id - In the untyped splice: $(conE 'id) + • In the untyped splice: $(conE 'id) diff --git a/testsuite/tests/th/T15270B.stderr b/testsuite/tests/th/T15270B.stderr index 3403d13e2b..8db1dc4b6d 100644 --- a/testsuite/tests/th/T15270B.stderr +++ b/testsuite/tests/th/T15270B.stderr @@ -1,5 +1,5 @@ -T15270B.hs:8:7: - Illegal variable name: ‘Just’ +T15270B.hs:8:6: error: + • Illegal variable name: ‘Just’ When splicing a TH expression: GHC.Maybe.Just - In the untyped splice: $(varE 'Just) + • In the untyped splice: $(varE 'Just) diff --git a/testsuite/tests/th/T15324.stderr b/testsuite/tests/th/T15324.stderr index 49db9ed8d9..0879fff9d3 100644 --- a/testsuite/tests/th/T15324.stderr +++ b/testsuite/tests/th/T15324.stderr @@ -1,4 +1,4 @@ -T15324.hs:(5,3)-(7,6): Splicing declarations +T15324.hs:(5,2)-(7,7): Splicing declarations [d| f :: forall a. (Show a => a) -> a f _ = undefined |] ======> diff --git a/testsuite/tests/th/T15331.stderr b/testsuite/tests/th/T15331.stderr index 99bfdfd198..dee7e8c8d0 100644 --- a/testsuite/tests/th/T15331.stderr +++ b/testsuite/tests/th/T15331.stderr @@ -1,4 +1,4 @@ -T15331.hs:(7,3)-(9,6): Splicing declarations +T15331.hs:(7,2)-(9,7): Splicing declarations [d| f :: Proxy (Int -> Int) f = Proxy @(Int -> Int) |] ======> diff --git a/testsuite/tests/th/T15360b.stderr b/testsuite/tests/th/T15360b.stderr index aa3f6d93de..7bfacf202e 100644 --- a/testsuite/tests/th/T15360b.stderr +++ b/testsuite/tests/th/T15360b.stderr @@ -1,20 +1,20 @@ -T15360b.hs:10:14: error: +T15360b.hs:10:13: error: • Expected kind ‘* -> k3’, but ‘Type’ has kind ‘*’ • In the first argument of ‘Proxy’, namely ‘(Type Double)’ In the type signature: x :: Proxy (Type Double) -T15360b.hs:13:14: error: +T15360b.hs:13:13: error: • Expected kind ‘* -> k2’, but ‘1’ has kind ‘GHC.Types.Nat’ • In the first argument of ‘Proxy’, namely ‘(1 Int)’ In the type signature: y :: Proxy (1 Int) -T15360b.hs:16:14: error: +T15360b.hs:16:13: error: • Expected kind ‘* -> k1’, but ‘Constraint’ has kind ‘*’ • In the first argument of ‘Proxy’, namely ‘(Constraint Bool)’ In the type signature: z :: Proxy (Constraint Bool) -T15360b.hs:19:14: error: +T15360b.hs:19:13: error: • Expected kind ‘* -> k0’, but ‘'[]’ has kind ‘[a0]’ • In the first argument of ‘Proxy’, namely ‘('[] Int)’ In the type signature: w :: Proxy ('[] Int) diff --git a/testsuite/tests/th/T15365.stderr b/testsuite/tests/th/T15365.stderr index 9631319eab..42f9806945 100644 --- a/testsuite/tests/th/T15365.stderr +++ b/testsuite/tests/th/T15365.stderr @@ -1,4 +1,4 @@ -T15365.hs:(9,3)-(31,6): Splicing declarations +T15365.hs:(9,2)-(31,7): Splicing declarations [d| (&&&) :: Bool -> Bool -> Bool (&&&) = (&&) pattern (:!!!) :: Bool diff --git a/testsuite/tests/th/T15481.stderr b/testsuite/tests/th/T15481.stderr index 69a8c7b0e7..01e508f498 100644 --- a/testsuite/tests/th/T15481.stderr +++ b/testsuite/tests/th/T15481.stderr @@ -1,4 +1,4 @@ -T15481.hs:(7,19)-(10,63): Splicing expression +T15481.hs:(7,18)-(10,64): Splicing expression recover (stringE "reifyFixity failed") (do foo <- newName "foo" diff --git a/testsuite/tests/th/T15502.stderr-ws-32 b/testsuite/tests/th/T15502.stderr-ws-32 index ba7b91c4a5..c7ccfd04a5 100644 --- a/testsuite/tests/th/T15502.stderr-ws-32 +++ b/testsuite/tests/th/T15502.stderr-ws-32 @@ -1,4 +1,4 @@ -T15502.hs:7:19-56: Splicing expression +T15502.hs:7:17-58: Splicing expression lift (toInteger (maxBound :: Int) + 1) ======> 2147483648 -T15502.hs:8:19-40: Splicing expression +T15502.hs:8:17-42: Splicing expression lift (minBound :: Int) ======> (-2147483648) diff --git a/testsuite/tests/th/T15502.stderr-ws-64 b/testsuite/tests/th/T15502.stderr-ws-64 index 1177799775..ba61ba3d1b 100644 --- a/testsuite/tests/th/T15502.stderr-ws-64 +++ b/testsuite/tests/th/T15502.stderr-ws-64 @@ -1,4 +1,4 @@ -T15502.hs:7:19-56: Splicing expression +T15502.hs:7:17-58: Splicing expression lift (toInteger (maxBound :: Int) + 1) ======> 9223372036854775808 -T15502.hs:8:19-40: Splicing expression +T15502.hs:8:17-42: Splicing expression lift (minBound :: Int) ======> (-9223372036854775808) diff --git a/testsuite/tests/th/T15518.stderr b/testsuite/tests/th/T15518.stderr index 7d9ef293b4..2eee5ccb8e 100644 --- a/testsuite/tests/th/T15518.stderr +++ b/testsuite/tests/th/T15518.stderr @@ -1,4 +1,4 @@ -T15518.hs:(5,3)-(8,6): Splicing declarations +T15518.hs:(5,2)-(8,7): Splicing declarations [d| f :: Bool -> () f = \case True -> () diff --git a/testsuite/tests/th/T15550.stderr b/testsuite/tests/th/T15550.stderr index 8169d75613..4c64d4a358 100644 --- a/testsuite/tests/th/T15550.stderr +++ b/testsuite/tests/th/T15550.stderr @@ -1,4 +1,4 @@ -T15550.hs:(4,3)-(8,6): Splicing declarations +T15550.hs:(4,2)-(8,7): Splicing declarations [d| {-# RULES "myId" forall x. myId x = x #-} myId :: a -> a diff --git a/testsuite/tests/th/T15572.stderr b/testsuite/tests/th/T15572.stderr index 27132d69e0..ad077d887a 100644 --- a/testsuite/tests/th/T15572.stderr +++ b/testsuite/tests/th/T15572.stderr @@ -1,6 +1,6 @@ -T15572.hs:7:3-33: Splicing declarations - [d| type AbsoluteUnit1 = '() |] ======> type AbsoluteUnit1 = '() -T15572.hs:8:3-54: Splicing declarations +T15572.hs:7:2-34: Splicing declarations + [d| type AbsoluteUnit1 = '() |] ======> type AbsoluteUnit1 = '() +T15572.hs:8:2-55: Splicing declarations pure [TySynD (mkName "AbsoluteUnit2") [] (ConT '())] ======> - type AbsoluteUnit2 = '() + type AbsoluteUnit2 = '() diff --git a/testsuite/tests/th/T15738.stderr b/testsuite/tests/th/T15738.stderr index 57a2db5832..580a02a62e 100644 --- a/testsuite/tests/th/T15738.stderr +++ b/testsuite/tests/th/T15738.stderr @@ -1,7 +1,7 @@ f_0 :: (forall a_1 . GHC.Classes.Eq (T15738.Foo a_1)) => T15738.Foo x_2 -> T15738.Foo x_2 -> GHC.Types.Bool f_0 = (GHC.Classes.==) -T15738.hs:(10,3)-(13,11): Splicing declarations +T15738.hs:(10,2)-(13,12): Splicing declarations do d <- [d| f :: (forall a. Eq (Foo a)) => Foo x -> Foo x -> Bool f = (==) |] runIO $ hPutStrLn stderr $ pprint d diff --git a/testsuite/tests/th/T16133.stderr b/testsuite/tests/th/T16133.stderr index 30dcd3ada0..3901f4d491 100644 --- a/testsuite/tests/th/T16133.stderr +++ b/testsuite/tests/th/T16133.stderr @@ -1,8 +1,8 @@ -T16133.hs:10:3: error: +T16133.hs:10:2: error: Illegal visible kind application ‘@Type’ Perhaps you intended to use TypeApplications -T16133.hs:10:3: error: +T16133.hs:10:2: error: Illegal visible type application ‘@Int’ Perhaps you intended to use TypeApplications diff --git a/testsuite/tests/th/T16183.stderr b/testsuite/tests/th/T16183.stderr index 812fd58ac9..c6951641b3 100644 --- a/testsuite/tests/th/T16183.stderr +++ b/testsuite/tests/th/T16183.stderr @@ -1,4 +1,4 @@ -T16183.hs:(7,3)-(11,40): Splicing declarations +T16183.hs:(7,2)-(11,41): Splicing declarations [d| type F1 = (Maybe :: Type -> Type) Int type F2 = (Int :: Type) -> (Int :: Type) type family F3 a where diff --git a/testsuite/tests/th/T16326_TH.stderr b/testsuite/tests/th/T16326_TH.stderr index 8a41fd116d..bf9c20be73 100644 --- a/testsuite/tests/th/T16326_TH.stderr +++ b/testsuite/tests/th/T16326_TH.stderr @@ -8,7 +8,7 @@ data Nested_0 :: forall a_1 . Data.Proxy.Proxy ('(:) a_1 ('(:) b_2 ('(:) c_3 ('(:) d_4 ('(:) e_5 '[]))))) -> * -T16326_TH.hs:(17,3)-(24,13): Splicing declarations +T16326_TH.hs:(17,2)-(24,14): Splicing declarations do info <- reify ''Foo2 liftIO $ hPutStrLn stderr $ pprint info dec <- [d| data Nested :: forall a. diff --git a/testsuite/tests/th/T16666.stderr b/testsuite/tests/th/T16666.stderr index 8264967396..fcacf77076 100644 --- a/testsuite/tests/th/T16666.stderr +++ b/testsuite/tests/th/T16666.stderr @@ -1,4 +1,4 @@ -T16666.hs:(9,3)-(11,6): Splicing declarations +T16666.hs:(9,2)-(11,7): Splicing declarations [d| class (c => d) => Implies c d instance (c => d) => Implies c d |] diff --git a/testsuite/tests/th/T16895a.stderr b/testsuite/tests/th/T16895a.stderr index d4b98c944a..5a5222eb50 100644 --- a/testsuite/tests/th/T16895a.stderr +++ b/testsuite/tests/th/T16895a.stderr @@ -1,5 +1,5 @@ -T16895a.hs:7:16: error: +T16895a.hs:7:15: error: • Non-variable expression is not allowed in an infix expression When splicing a TH expression: 1 `GHC.Base.id GHC.Base.id` 2 • In the untyped splice: $(uInfixE [| 1 |] [| id id |] [| 2 |]) diff --git a/testsuite/tests/th/T16895b.stderr b/testsuite/tests/th/T16895b.stderr index 8309912f64..597736cad4 100644 --- a/testsuite/tests/th/T16895b.stderr +++ b/testsuite/tests/th/T16895b.stderr @@ -1,6 +1,6 @@ -T16895b.hs:7:16: - Non-variable expression is not allowed in an infix expression +T16895b.hs:7:15: error: + • Non-variable expression is not allowed in an infix expression When splicing a TH expression: (`GHC.Base.id GHC.Base.id` 2) - In the untyped splice: + • In the untyped splice: $(infixE Nothing [| id id |] (Just [| 2 |])) diff --git a/testsuite/tests/th/T16895c.stderr b/testsuite/tests/th/T16895c.stderr index 38475cce3c..baa5e7526b 100644 --- a/testsuite/tests/th/T16895c.stderr +++ b/testsuite/tests/th/T16895c.stderr @@ -1,6 +1,6 @@ -T16895c.hs:7:16: - Non-variable expression is not allowed in an infix expression +T16895c.hs:7:15: error: + • Non-variable expression is not allowed in an infix expression When splicing a TH expression: (1 `GHC.Base.id GHC.Base.id`) - In the untyped splice: + • In the untyped splice: $(infixE (Just [| 1 |]) [| id id |] Nothing) diff --git a/testsuite/tests/th/T16895d.stderr b/testsuite/tests/th/T16895d.stderr index 57ba8725ba..2832aee9be 100644 --- a/testsuite/tests/th/T16895d.stderr +++ b/testsuite/tests/th/T16895d.stderr @@ -1,6 +1,6 @@ -T16895d.hs:7:16: - Non-variable expression is not allowed in an infix expression +T16895d.hs:7:15: error: + • Non-variable expression is not allowed in an infix expression When splicing a TH expression: 1 `GHC.Base.id GHC.Base.id` 2 - In the untyped splice: + • In the untyped splice: $(infixE (Just [| 1 |]) [| (id id) |] (Just [| 2 |])) diff --git a/testsuite/tests/th/T16895e.stderr b/testsuite/tests/th/T16895e.stderr index 90884a09da..43d7ac460e 100644 --- a/testsuite/tests/th/T16895e.stderr +++ b/testsuite/tests/th/T16895e.stderr @@ -1,5 +1,5 @@ -T16895e.hs:7:16: - Non-variable expression is not allowed in an infix expression +T16895e.hs:7:15: error: + • Non-variable expression is not allowed in an infix expression When splicing a TH expression: (`GHC.Base.id GHC.Base.id`) - In the untyped splice: $(infixE Nothing [| id id |] Nothing) + • In the untyped splice: $(infixE Nothing [| id id |] Nothing) diff --git a/testsuite/tests/th/T17270.hs b/testsuite/tests/th/T17270.hs new file mode 100644 index 0000000000..72f85dddd6 --- /dev/null +++ b/testsuite/tests/th/T17270.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wall #-} +module T17270 where + +import Data.Type.Equality + +f :: a :~: Int -> b :~: Bool -> a :~: b -> void +f Refl Refl x = case x of {} + +$([d| g :: a :~: Int -> b :~: Bool -> a :~: b -> void + g Refl Refl x = case x of {} + |]) diff --git a/testsuite/tests/th/T17379a.stderr b/testsuite/tests/th/T17379a.stderr index ec98c5fb54..feee281ac2 100644 --- a/testsuite/tests/th/T17379a.stderr +++ b/testsuite/tests/th/T17379a.stderr @@ -1,4 +1,4 @@ -T17379a.hs:8:3: +T17379a.hs:8:2: error: GadtC must have at least one constructor name When splicing a TH declaration: data T where :: T diff --git a/testsuite/tests/th/T17379b.stderr b/testsuite/tests/th/T17379b.stderr index 47410ecdd0..54285bde18 100644 --- a/testsuite/tests/th/T17379b.stderr +++ b/testsuite/tests/th/T17379b.stderr @@ -1,4 +1,4 @@ -T17379b.hs:8:3: +T17379b.hs:8:2: error: RecGadtC must have at least one constructor name When splicing a TH declaration: data T where :: {} -> T diff --git a/testsuite/tests/th/T17380.stderr b/testsuite/tests/th/T17380.stderr index a2501a4cb4..85724eb549 100644 --- a/testsuite/tests/th/T17380.stderr +++ b/testsuite/tests/th/T17380.stderr @@ -5,7 +5,7 @@ T17380.hs:9:7: error: • In the expression: Just "wat" In an equation for ‘foo’: foo = Just "wat" -T17380.hs:12:9: error: +T17380.hs:12:8: error: • Couldn't match expected type ‘Maybe String’ with actual type ‘Unit (Maybe [Char])’ • In the expression: Unit Just "wat" @@ -17,7 +17,7 @@ T17380.hs:15:6: error: • In the pattern: Just "wat" In an equation for ‘baz’: baz (Just "wat") = Just "frerf" -T17380.hs:18:8: error: +T17380.hs:18:7: error: • Couldn't match expected type ‘Maybe String’ with actual type ‘Unit (Maybe [Char])’ • In the pattern: Unit(Just "wat") diff --git a/testsuite/tests/th/T17394.stderr b/testsuite/tests/th/T17394.stderr index c4ad33a671..b4551f763d 100644 --- a/testsuite/tests/th/T17394.stderr +++ b/testsuite/tests/th/T17394.stderr @@ -1,8 +1,8 @@ -T17394.hs:10:13-65: Splicing type +T17394.hs:10:12-66: Splicing type infixT (conT ''Maybe) ''(:*:) (conT ''Maybe) ======> (:*:) Maybe Maybe -T17394.hs:9:13-67: Splicing type +T17394.hs:9:12-68: Splicing type infixT (promotedT 'Nothing) '(:*:) (promotedT 'Nothing) ======> '(:*:) 'Nothing 'Nothing diff --git a/testsuite/tests/th/T17461.stderr b/testsuite/tests/th/T17461.stderr index cc730400bf..f7b9f4b87c 100644 --- a/testsuite/tests/th/T17461.stderr +++ b/testsuite/tests/th/T17461.stderr @@ -1,4 +1,4 @@ -T17461.hs:(8,3)-(10,6): Splicing declarations +T17461.hs:(8,2)-(10,7): Splicing declarations [d| type (:+:) :: Type -> Type -> Type type (:+:) = Either |] diff --git a/testsuite/tests/th/T2597b.stderr b/testsuite/tests/th/T2597b.stderr index 0e897ccfcb..aba3925113 100644 --- a/testsuite/tests/th/T2597b.stderr +++ b/testsuite/tests/th/T2597b.stderr @@ -1,5 +1,5 @@ -T2597b.hs:8:8: - Empty stmt list in do-block - When splicing a TH expression: do - In the untyped splice: $mkBug2 +T2597b.hs:8:9: error: + • Empty stmt list in do-block + When splicing a TH expression: do + • In the untyped splice: $mkBug2 diff --git a/testsuite/tests/th/T2674.stderr b/testsuite/tests/th/T2674.stderr index 0d9a3826ff..9c7f0baff7 100644 --- a/testsuite/tests/th/T2674.stderr +++ b/testsuite/tests/th/T2674.stderr @@ -1,4 +1,4 @@ -T2674.hs:9:3: +T2674.hs:9:2: error: Function binding for ‘foo’ has no equations When splicing a TH declaration: diff --git a/testsuite/tests/th/T3177a.stderr b/testsuite/tests/th/T3177a.stderr index d68be6d1fc..a9b8bed980 100644 --- a/testsuite/tests/th/T3177a.stderr +++ b/testsuite/tests/th/T3177a.stderr @@ -1,5 +1,5 @@ -T3177a.hs:8:8: error: +T3177a.hs:8:7: error: • Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ • In the type signature: f :: (Int Int) diff --git a/testsuite/tests/th/T3319.stderr b/testsuite/tests/th/T3319.stderr index b88b10f90f..7ecaf248cc 100644 --- a/testsuite/tests/th/T3319.stderr +++ b/testsuite/tests/th/T3319.stderr @@ -1,4 +1,4 @@ -T3319.hs:8:3-93: Splicing declarations +T3319.hs:8:2-94: Splicing declarations return [ForeignD (ImportF diff --git a/testsuite/tests/th/T3395.stderr b/testsuite/tests/th/T3395.stderr index 3c51176191..a9bcdbedba 100644 --- a/testsuite/tests/th/T3395.stderr +++ b/testsuite/tests/th/T3395.stderr @@ -1,11 +1,11 @@ -T3395.hs:6:9: - Illegal last statement of a list comprehension: - r1 <- undefined - (It should be an expression.) - When splicing a TH expression: [r1 <- undefined | undefined] - In the untyped splice: - $(return - $ CompE - [NoBindS (VarE $ mkName "undefined"), - BindS (VarP $ mkName "r1") (VarE $ mkName "undefined")]) +T3395.hs:6:8: error: + • Illegal last statement of a list comprehension: + r1 <- undefined + (It should be an expression.) + When splicing a TH expression: [r1 <- undefined | undefined] + • In the untyped splice: + $(return + $ CompE + [NoBindS (VarE $ mkName "undefined"), + BindS (VarP $ mkName "r1") (VarE $ mkName "undefined")]) diff --git a/testsuite/tests/th/T3600.stderr b/testsuite/tests/th/T3600.stderr index 4f63ef191a..b0ea19da58 100644 --- a/testsuite/tests/th/T3600.stderr +++ b/testsuite/tests/th/T3600.stderr @@ -1,2 +1,2 @@ -T3600.hs:5:3-6: Splicing declarations +T3600.hs:5:2-7: Splicing declarations test ======> myFunction = (testFun1 [], testFun2 [], testFun2 "x") diff --git a/testsuite/tests/th/T3899.stderr b/testsuite/tests/th/T3899.stderr index 2b4a76a4e5..3c4a707409 100644 --- a/testsuite/tests/th/T3899.stderr +++ b/testsuite/tests/th/T3899.stderr @@ -1,2 +1,2 @@ -T3899.hs:6:7-19: Splicing expression +T3899.hs:6:6-20: Splicing expression nestedTuple 3 ======> \ (Cons x (Cons x (Cons x Nil))) -> (x, x, x) diff --git a/testsuite/tests/th/T4436.stderr b/testsuite/tests/th/T4436.stderr index d87bfc1a2f..f7ed0e12fe 100644 --- a/testsuite/tests/th/T4436.stderr +++ b/testsuite/tests/th/T4436.stderr @@ -1,5 +1,5 @@ -T4436.hs:5:7-56: Splicing expression - return (LitE (StringL "hello/ngoodbye/nand then")) +T4436.hs:5:6-57: Splicing expression + return (LitE (StringL "hello\ngoodbye\nand then")) ======> "hello goodbye diff --git a/testsuite/tests/th/T5217.stderr b/testsuite/tests/th/T5217.stderr index 30797a8934..04b4d2526d 100644 --- a/testsuite/tests/th/T5217.stderr +++ b/testsuite/tests/th/T5217.stderr @@ -1,4 +1,4 @@ -T5217.hs:(6,3)-(9,53): Splicing declarations +T5217.hs:(6,2)-(9,54): Splicing declarations [d| data T a b where T1 :: Int -> T Int Char diff --git a/testsuite/tests/th/T5290.stderr b/testsuite/tests/th/T5290.stderr index 19c962a9a0..f595e55d18 100644 --- a/testsuite/tests/th/T5290.stderr +++ b/testsuite/tests/th/T5290.stderr @@ -1,13 +1,9 @@ -T5290.hs:(7,4)-(9,77): Splicing declarations +T5290.hs:(7,2)-(9,79): Splicing declarations let n = mkName "T" in return [DataD - [] - n - [] - Nothing - [NormalC n [(Bang SourceUnpack SourceStrict, ConT ''Int)]] - []] + [] n [] Nothing + [NormalC n [(Bang SourceUnpack SourceStrict, ConT ''Int)]] []] ======> data T = T {-# UNPACK #-} !Int diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr index cc1df54bed..6561e08032 100644 --- a/testsuite/tests/th/T5358.stderr +++ b/testsuite/tests/th/T5358.stderr @@ -34,8 +34,8 @@ T5358.hs:14:12: error: runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool CallStack (from HasCallStack): error, called at T5358.hs:15:18 in main:T5358 - Code: do VarI _ t _ <- reify (mkName "prop_x1") - error $ ("runTest called error: " ++ pprint t) + Code: (do VarI _ t _ <- reify (mkName "prop_x1") + error $ ("runTest called error: " ++ pprint t)) • In the untyped splice: $(do VarI _ t _ <- reify (mkName "prop_x1") error $ ("runTest called error: " ++ pprint t)) diff --git a/testsuite/tests/th/T5508.stderr b/testsuite/tests/th/T5508.stderr index 7000204913..5511ec6134 100644 --- a/testsuite/tests/th/T5508.stderr +++ b/testsuite/tests/th/T5508.stderr @@ -1,4 +1,4 @@ -T5508.hs:(7,9)-(9,28): Splicing expression +T5508.hs:(7,8)-(9,29): Splicing expression do let x = mkName "x" v = return (LamE [VarP x] $ VarE x) [| $v . id |] diff --git a/testsuite/tests/th/T5700.stderr b/testsuite/tests/th/T5700.stderr index 3564b8cb2a..4be063203a 100644 --- a/testsuite/tests/th/T5700.stderr +++ b/testsuite/tests/th/T5700.stderr @@ -1,4 +1,4 @@ -T5700.hs:8:3-9: Splicing declarations +T5700.hs:8:2-10: Splicing declarations mkC ''D ======> instance C D where diff --git a/testsuite/tests/th/T5795.stderr b/testsuite/tests/th/T5795.stderr index 79e9f92d17..95af718c98 100644 --- a/testsuite/tests/th/T5795.stderr +++ b/testsuite/tests/th/T5795.stderr @@ -1,6 +1,6 @@ -T5795.hs:9:6: - GHC stage restriction: - ‘ty’ is used in a top-level splice, quasi-quote, or annotation, - and must be imported, not defined locally - In the untyped splice: $ty +T5795.hs:9:7: error: + • GHC stage restriction: + ‘ty’ is used in a top-level splice, quasi-quote, or annotation, + and must be imported, not defined locally + • In the untyped splice: $ty diff --git a/testsuite/tests/th/T5883.stderr b/testsuite/tests/th/T5883.stderr index aa87a41052..04db65b7ed 100644 --- a/testsuite/tests/th/T5883.stderr +++ b/testsuite/tests/th/T5883.stderr @@ -1,4 +1,4 @@ -T5883.hs:(7,4)-(12,4): Splicing declarations +T5883.hs:(7,2)-(12,5): Splicing declarations [d| data Unit = Unit instance Show Unit where diff --git a/testsuite/tests/th/T5971.stderr b/testsuite/tests/th/T5971.stderr index d48c2255bd..c8164cd1df 100644 --- a/testsuite/tests/th/T5971.stderr +++ b/testsuite/tests/th/T5971.stderr @@ -1,7 +1,7 @@ -T5971.hs:6:7: - The exact Name ‘x’ is not in scope - Probable cause: you used a unique Template Haskell name (NameU), - perhaps via newName, but did not bind it - If that's it, then -ddump-splices might be useful - In the untyped splice: $(newName "x" >>= varE) +T5971.hs:6:6: error: + • The exact Name ‘x’ is not in scope + Probable cause: you used a unique Template Haskell name (NameU), + perhaps via newName, but did not bind it + If that's it, then -ddump-splices might be useful + • In the untyped splice: $(newName "x" >>= varE) diff --git a/testsuite/tests/th/T5976.stderr b/testsuite/tests/th/T5976.stderr index f4e9568927..7d815f2b30 100644 --- a/testsuite/tests/th/T5976.stderr +++ b/testsuite/tests/th/T5976.stderr @@ -4,4 +4,4 @@ T5976.hs:1:1: error: bar CallStack (from HasCallStack): error, called at T5976.hs:3:21 in main:Main - Code: error ("foo " ++ error "bar") + Code: (error ("foo " ++ error "bar")) diff --git a/testsuite/tests/th/T5984.stderr b/testsuite/tests/th/T5984.stderr index 2e612c7e9e..3bd89f1552 100644 --- a/testsuite/tests/th/T5984.stderr +++ b/testsuite/tests/th/T5984.stderr @@ -1,8 +1,3 @@ -T5984.hs:7:1-3: Splicing declarations - nt - ======> - newtype Foo = Foo Int -T5984.hs:8:1-3: Splicing declarations - dt - ======> - data Bar = Bar Int +T5984.hs:7:2-3: Splicing declarations + nt ======> newtype Foo = Foo Int +T5984.hs:8:2-3: Splicing declarations dt ======> data Bar = Bar Int diff --git a/testsuite/tests/th/T6018th.stderr b/testsuite/tests/th/T6018th.stderr index b905fe8bf1..c141bfc44a 100644 --- a/testsuite/tests/th/T6018th.stderr +++ b/testsuite/tests/th/T6018th.stderr @@ -1,6 +1,6 @@ -T6018th.hs:98:4: error: +T6018th.hs:98:2: error: Type family equation right-hand sides overlap; this violates the family's injectivity annotation: - H Int Int Int = Bool -- Defined at T6018th.hs:98:4 - H Int Char Bool = Bool -- Defined at T6018th.hs:98:4 + H Int Int Int = Bool -- Defined at T6018th.hs:98:2 + H Int Char Bool = Bool -- Defined at T6018th.hs:98:2 diff --git a/testsuite/tests/th/T7241.stderr b/testsuite/tests/th/T7241.stderr index 07d17c9da3..1681b45f51 100644 --- a/testsuite/tests/th/T7241.stderr +++ b/testsuite/tests/th/T7241.stderr @@ -1,8 +1,8 @@ -T7241.hs:7:3: error: +T7241.hs:7:2: error: Same exact name in multiple name-spaces: - type constructor or class ‘Foo’, declared at: T7241.hs:7:3 - data constructor ‘Foo’, declared at: T7241.hs:7:3 + type constructor or class ‘Foo’, declared at: T7241.hs:7:2 + data constructor ‘Foo’, declared at: T7241.hs:7:2 Probable cause: you bound a unique Template Haskell name (NameU), perhaps via newName, in different name-spaces. If that's it, then -ddump-splices might be useful diff --git a/testsuite/tests/th/T7477.stderr b/testsuite/tests/th/T7477.stderr index f94de686d0..7aee71ea74 100644 --- a/testsuite/tests/th/T7477.stderr +++ b/testsuite/tests/th/T7477.stderr @@ -1,3 +1,3 @@ -T7477.hs:10:4: Warning: +T7477.hs:10:2: warning: type instance T7477.F GHC.Types.Int = GHC.Types.Bool diff --git a/testsuite/tests/th/T7484.stderr b/testsuite/tests/th/T7484.stderr index 3ffe123361..5964a2f73c 100644 --- a/testsuite/tests/th/T7484.stderr +++ b/testsuite/tests/th/T7484.stderr @@ -1,4 +1,4 @@ -T7484.hs:7:4: +T7484.hs:7:2: error: Illegal variable name: ‘a ’ When splicing a TH declaration: a = 5 diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr index baaf04f3f5..d807c37db1 100644 --- a/testsuite/tests/th/T7532.stderr +++ b/testsuite/tests/th/T7532.stderr @@ -3,7 +3,7 @@ instance C Bool where data D Bool = T7532.MkD -T7532.hs:11:3-7: Splicing declarations +T7532.hs:11:2-8: Splicing declarations bang' ======> instance C Int where diff --git a/testsuite/tests/th/T7667a.stderr b/testsuite/tests/th/T7667a.stderr index ca8b8f2145..b9807f0e0c 100644 --- a/testsuite/tests/th/T7667a.stderr +++ b/testsuite/tests/th/T7667a.stderr @@ -1,5 +1,5 @@ -T7667a.hs:8:12: - Illegal variable name: ‘False’ - When splicing a TH expression: False - In the untyped splice: $(return $ VarE (mkName "False")) +T7667a.hs:8:10: error: + • Illegal variable name: ‘False’ + When splicing a TH expression: False + • In the untyped splice: $(return $ VarE (mkName "False")) diff --git a/testsuite/tests/th/T8412.stderr b/testsuite/tests/th/T8412.stderr index 82b6116649..9e69b8e880 100644 --- a/testsuite/tests/th/T8412.stderr +++ b/testsuite/tests/th/T8412.stderr @@ -1,4 +1,4 @@ -T8412.hs:5:12: - Illegal literal in type (type literals must not be negative): -1 - In the untyped splice: $(return $ LitT $ NumTyLit (- 1)) +T8412.hs:5:11: error: + • Illegal literal in type (type literals must not be negative): -1 + • In the untyped splice: $(return $ LitT $ NumTyLit (- 1)) diff --git a/testsuite/tests/th/T8577.stderr b/testsuite/tests/th/T8577.stderr index 1a0fb75bd1..b6ff05a0a4 100644 --- a/testsuite/tests/th/T8577.stderr +++ b/testsuite/tests/th/T8577.stderr @@ -1,8 +1,8 @@ T8577.hs:9:11: error: - Couldn't match type ‘Int’ with ‘Bool’ - Expected type: Q (TExp (A Bool)) - Actual type: Q (TExp (A Int)) - In the expression: y - In the Template Haskell splice $$(y) - In the expression: $$(y) + • Couldn't match type ‘Int’ with ‘Bool’ + Expected type: Q (TExp (A Bool)) + Actual type: Q (TExp (A Int)) + • In the expression: y + In the Template Haskell splice $$(y) + In the expression: $$(y) diff --git a/testsuite/tests/th/T8624.stdout b/testsuite/tests/th/T8624.stdout index 0dcc7b0718..6286ee26d2 100644 --- a/testsuite/tests/th/T8624.stdout +++ b/testsuite/tests/th/T8624.stdout @@ -1,2 +1,2 @@ --- T8624.hs:(7,3)-(8,43): Splicing declarations +-- T8624.hs:(7,2)-(8,44): Splicing declarations data THDec = THDec diff --git a/testsuite/tests/th/T8759.stderr b/testsuite/tests/th/T8759.stderr index b980c00293..d3cde8b0a8 100644 --- a/testsuite/tests/th/T8759.stderr +++ b/testsuite/tests/th/T8759.stderr @@ -1,3 +1,3 @@ -T8759.hs:9:4: warning: +T8759.hs:9:2: warning: PatSynI T8759.P (ForallT [] [] (ForallT [] [] (TupleT 0))) diff --git a/testsuite/tests/th/T8932.stderr b/testsuite/tests/th/T8932.stderr index 96e5d8a9fc..4dbbfe620a 100644 --- a/testsuite/tests/th/T8932.stderr +++ b/testsuite/tests/th/T8932.stderr @@ -1,5 +1,5 @@ T8932.hs:11:1: error: Multiple declarations of ‘foo’ - Declared at: T8932.hs:5:3 + Declared at: T8932.hs:5:2 T8932.hs:11:1 diff --git a/testsuite/tests/th/T8987.stderr b/testsuite/tests/th/T8987.stderr index 7b5f400f6f..00181fa2db 100644 --- a/testsuite/tests/th/T8987.stderr +++ b/testsuite/tests/th/T8987.stderr @@ -5,4 +5,4 @@ T8987.hs:1:1: error: CallStack (from HasCallStack): error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err undefined, called at T8987.hs:6:23 in main:T8987 - Code: reportWarning ['1', undefined] >> return [] + Code: (reportWarning ['1', undefined] >> return []) diff --git a/testsuite/tests/th/TH_1tuple.stderr b/testsuite/tests/th/TH_1tuple.stderr index 3acb218b6e..07b6584242 100644 --- a/testsuite/tests/th/TH_1tuple.stderr +++ b/testsuite/tests/th/TH_1tuple.stderr @@ -1,5 +1,5 @@ -TH_1tuple.hs:11:7: error: +TH_1tuple.hs:11:6: error: • Expecting one more argument to ‘Unit’ Expected a type, but ‘Unit’ has kind ‘* -> *’ • In an expression type signature: Unit diff --git a/testsuite/tests/th/TH_Promoted1Tuple.stderr b/testsuite/tests/th/TH_Promoted1Tuple.stderr index 495fb1c386..d75a6260fa 100644 --- a/testsuite/tests/th/TH_Promoted1Tuple.stderr +++ b/testsuite/tests/th/TH_Promoted1Tuple.stderr @@ -1,3 +1,3 @@ -TH_Promoted1Tuple.hs:7:3: error: +TH_Promoted1Tuple.hs:7:2: error: Illegal type: ‘'Unit Int’ Perhaps you intended to use DataKinds diff --git a/testsuite/tests/th/TH_PromotedList.stderr b/testsuite/tests/th/TH_PromotedList.stderr index fde888ff88..d3eba9ac0e 100644 --- a/testsuite/tests/th/TH_PromotedList.stderr +++ b/testsuite/tests/th/TH_PromotedList.stderr @@ -1,3 +1,3 @@ -TH_PromotedList.hs:11:3: warning: +TH_PromotedList.hs:11:2: warning: '(:) GHC.Types.Int ('(:) GHC.Types.Bool '[]) diff --git a/testsuite/tests/th/TH_PromotedTuple.stderr b/testsuite/tests/th/TH_PromotedTuple.stderr index 92792a361d..29b60f08fd 100644 --- a/testsuite/tests/th/TH_PromotedTuple.stderr +++ b/testsuite/tests/th/TH_PromotedTuple.stderr @@ -1,9 +1,9 @@ -TH_PromotedTuple.hs:(14,32)-(16,43): Splicing type +TH_PromotedTuple.hs:(14,31)-(16,44): Splicing type do ty <- [t| '(Int, False) |] reportWarning (show ty) return ty ======> - '(Int, 'False) + '(Int, 'False) -TH_PromotedTuple.hs:14:32: warning: +TH_PromotedTuple.hs:14:31: warning: AppT (AppT (PromotedTupleT 2) (ConT GHC.Types.Int)) (PromotedT GHC.Types.False) diff --git a/testsuite/tests/th/TH_RichKinds.stderr b/testsuite/tests/th/TH_RichKinds.stderr index eb402902ac..920e424e52 100644 --- a/testsuite/tests/th/TH_RichKinds.stderr +++ b/testsuite/tests/th/TH_RichKinds.stderr @@ -1,9 +1,9 @@ -TH_RichKinds.hs:12:3: warning: +TH_RichKinds.hs:12:2: warning: forall a_0 . (a_0 :: GHC.Types.Bool) forall a_1 . (a_1 :: Constraint) forall a_2 . (a_2 :: [*]) forall a_3 . (a_3 :: (*, GHC.Types.Bool)) forall a_4 . (a_4 :: ()) -forall a_5 . (a_5 :: (* -> GHC.Types.Bool) -> - (*, * -> *) -> GHC.Types.Bool) +forall a_5 . +(a_5 :: (* -> GHC.Types.Bool) -> (*, * -> *) -> GHC.Types.Bool) diff --git a/testsuite/tests/th/TH_RichKinds2.stderr b/testsuite/tests/th/TH_RichKinds2.stderr index a0b29a15e3..ae842d43a6 100644 --- a/testsuite/tests/th/TH_RichKinds2.stderr +++ b/testsuite/tests/th/TH_RichKinds2.stderr @@ -1,5 +1,5 @@ -TH_RichKinds2.hs:25:4: warning: +TH_RichKinds2.hs:25:2: warning: data SMaybe_0 :: (k_0 -> *) -> GHC.Maybe.Maybe k_0 -> * where SNothing_2 :: SMaybe_0 s_3 'GHC.Maybe.Nothing SJust_4 :: (s_5 a_6) -> SMaybe_0 s_5 ('GHC.Maybe.Just a_6) diff --git a/testsuite/tests/th/TH_Roles1.stderr b/testsuite/tests/th/TH_Roles1.stderr index 952b3317ce..2b665852ca 100644 --- a/testsuite/tests/th/TH_Roles1.stderr +++ b/testsuite/tests/th/TH_Roles1.stderr @@ -1,5 +1,5 @@ -TH_Roles1.hs:7:4: - Illegal role annotation for T; - did you intend to use RoleAnnotations? - while checking a role annotation for ‘T’ +TH_Roles1.hs:7:2: error: + • Illegal role annotation for T; + did you intend to use RoleAnnotations? + • while checking a role annotation for ‘T’ diff --git a/testsuite/tests/th/TH_StaticPointers02.stderr b/testsuite/tests/th/TH_StaticPointers02.stderr index e6f6963434..a89ad11b0d 100644 --- a/testsuite/tests/th/TH_StaticPointers02.stderr +++ b/testsuite/tests/th/TH_StaticPointers02.stderr @@ -1,12 +1,12 @@ -TH_StaticPointers02.hs:11:34: - static forms cannot be used in splices: static 'a' - In the untyped splice: - $(case staticKey (static 'a') of { - Fingerprint w0 w1 - -> let - w0i = ... - .... - in - [| fmap (\ p -> ...) $ unsafeLookupStaticPtr - $ Fingerprint (fromIntegral w0i) (fromIntegral w1i) |] }) +TH_StaticPointers02.hs:11:34: error: + • static forms cannot be used in splices: static 'a' + • In the untyped splice: + $(case staticKey (static 'a') of { + Fingerprint w0 w1 + -> let + w0i = ... + w1i = ... + in + [| fmap (\ p -> deRefStaticPtr p :: Char) $ unsafeLookupStaticPtr + $ Fingerprint (fromIntegral w0i) (fromIntegral w1i) |] }) diff --git a/testsuite/tests/th/TH_TyInstWhere1.stderr b/testsuite/tests/th/TH_TyInstWhere1.stderr index 0d07db83d1..4f5d278afd 100644 --- a/testsuite/tests/th/TH_TyInstWhere1.stderr +++ b/testsuite/tests/th/TH_TyInstWhere1.stderr @@ -1,8 +1,8 @@ -TH_TyInstWhere1.hs:(5,3)-(7,24): Splicing declarations +TH_TyInstWhere1.hs:(5,2)-(7,25): Splicing declarations [d| type family F (a :: k) (b :: k) :: Bool where F a a = True F a b = False |] ======> type family F (a :: k) (b :: k) :: Bool where - F a a = 'True - F a b = 'False + F a a = 'True + F a b = 'False diff --git a/testsuite/tests/th/TH_TyInstWhere2.stderr b/testsuite/tests/th/TH_TyInstWhere2.stderr index 717fb0e170..c79af948a6 100644 --- a/testsuite/tests/th/TH_TyInstWhere2.stderr +++ b/testsuite/tests/th/TH_TyInstWhere2.stderr @@ -1,10 +1,10 @@ -TH_TyInstWhere2.hs:8:4: warning: +TH_TyInstWhere2.hs:8:2: warning: type family F_0 (a_1 :: k_2) (b_3 :: k_2) :: GHC.Types.Bool where F_0 a_4 a_4 = 'GHC.Types.True F_0 a_5 b_6 = 'GHC.Types.False -TH_TyInstWhere2.hs:14:4: warning: +TH_TyInstWhere2.hs:14:2: warning: type family F1_0 (a_1 :: k_2) :: * where F1_0 @* GHC.Types.Int = GHC.Types.Bool F1_0 @GHC.Types.Bool 'GHC.Types.False = GHC.Types.Char diff --git a/testsuite/tests/th/TH_dupdecl.stderr b/testsuite/tests/th/TH_dupdecl.stderr index e08af85233..c44ba63098 100644 --- a/testsuite/tests/th/TH_dupdecl.stderr +++ b/testsuite/tests/th/TH_dupdecl.stderr @@ -1,5 +1,5 @@ -TH_dupdecl.hs:10:4: +TH_dupdecl.hs:10:2: error: Multiple declarations of ‘x’ - Declared at: TH_dupdecl.hs:8:4 - TH_dupdecl.hs:10:4 + Declared at: TH_dupdecl.hs:8:2 + TH_dupdecl.hs:10:2 diff --git a/testsuite/tests/th/TH_exn1.stderr b/testsuite/tests/th/TH_exn1.stderr index 63548613d8..69c854e244 100644 --- a/testsuite/tests/th/TH_exn1.stderr +++ b/testsuite/tests/th/TH_exn1.stderr @@ -1,6 +1,6 @@ -TH_exn1.hs:1:1: +TH_exn1.hs:1:1: error: Exception when trying to run compile-time code: TH_exn1.hs:(9,4)-(10,23): Non-exhaustive patterns in case - Code: case reverse "no" of { [] -> return [] } + Code: (case reverse "no" of { [] -> return [] }) diff --git a/testsuite/tests/th/TH_exn2.stderr b/testsuite/tests/th/TH_exn2.stderr index 3ccc9e1c0c..582928c08b 100644 --- a/testsuite/tests/th/TH_exn2.stderr +++ b/testsuite/tests/th/TH_exn2.stderr @@ -2,5 +2,5 @@ TH_exn2.hs:1:1: error: Exception when trying to run compile-time code: Prelude.tail: empty list - Code: do ds <- [d| |] - return (tail ds) + Code: (do ds <- [d| |] + return (tail ds)) diff --git a/testsuite/tests/th/TH_fail.stderr b/testsuite/tests/th/TH_fail.stderr index b73acbbb22..6df144dae4 100644 --- a/testsuite/tests/th/TH_fail.stderr +++ b/testsuite/tests/th/TH_fail.stderr @@ -1,2 +1,2 @@ -TH_fail.hs:7:4: Code not written yet... +TH_fail.hs:7:2: error: Code not written yet... diff --git a/testsuite/tests/th/TH_foreignCallingConventions.stderr b/testsuite/tests/th/TH_foreignCallingConventions.stderr index dae994539d..df09310652 100644 --- a/testsuite/tests/th/TH_foreignCallingConventions.stderr +++ b/testsuite/tests/th/TH_foreignCallingConventions.stderr @@ -8,20 +8,20 @@ foreign import stdcall safe "bay" bay :: (GHC.Types.Int -> GHC.Types.IO GHC.Types.Int foreign import javascript unsafe "bax" bax :: GHC.Ptr.Ptr GHC.Types.Int -> GHC.Types.IO GHC.Base.String -TH_foreignCallingConventions.hs:(13,4)-(23,25): Splicing declarations +TH_foreignCallingConventions.hs:(13,2)-(24,2): Splicing declarations do let fi cconv safety lbl name ty = ForeignD (ImportF cconv safety lbl name ty) dec1 <- fi CCall Interruptible "&" (mkName "foo") <$> [t| Ptr () |] dec2 <- fi Prim Safe "bar" (mkName "bar") <$> [t| Int# -> Int# |] dec3 <- fi CApi Unsafe "baz" (mkName "baz") - <$> [t| Double -> IO () |] + <$> [t| Double -> IO () |] dec4 <- fi StdCall Safe "bay" (mkName "bay") - <$> [t| (Int -> Bool) -> IO Int |] + <$> [t| (Int -> Bool) -> IO Int |] dec5 <- fi JavaScript Unsafe "bax" (mkName "bax") - <$> [t| Ptr Int -> IO String |] + <$> [t| Ptr Int -> IO String |] runIO - $ mapM_ (putStrLn . pprint) [dec1, dec2, dec3, dec4, dec5] - >> hFlush stdout + $ mapM_ (putStrLn . pprint) [dec1, dec2, dec3, dec4, dec5] + >> hFlush stdout return [dec1, dec2] ======> foreign import ccall interruptible "&" foo :: Ptr () diff --git a/testsuite/tests/th/TH_foreignInterruptible.stderr b/testsuite/tests/th/TH_foreignInterruptible.stderr index 4afc38aab1..28440eb8f0 100644 --- a/testsuite/tests/th/TH_foreignInterruptible.stderr +++ b/testsuite/tests/th/TH_foreignInterruptible.stderr @@ -1,11 +1,8 @@ -TH_foreignInterruptible.hs:8:3-100: Splicing declarations +TH_foreignInterruptible.hs:8:2-101: Splicing declarations return [ForeignD (ImportF - CCall - Interruptible - "&" - (mkName "foo") + CCall Interruptible "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))] ======> foreign import ccall interruptible "&" foo :: Ptr () diff --git a/testsuite/tests/th/TH_genEx.stderr b/testsuite/tests/th/TH_genEx.stderr index 8f2d5926e9..2c4c51c26c 100644 --- a/testsuite/tests/th/TH_genEx.stderr +++ b/testsuite/tests/th/TH_genEx.stderr @@ -1,5 +1,5 @@ -TH_genEx.hs:13:3-30: Splicing declarations +TH_genEx.hs:13:2-31: Splicing declarations genAny (reify ''MyInterface) ======> data AnyMyInterface1111 - = forall a. MyInterface a => AnyMyInterface1111 a + = forall a. MyInterface a => AnyMyInterface1111 a diff --git a/testsuite/tests/th/TH_implicitParamsErr1.stderr b/testsuite/tests/th/TH_implicitParamsErr1.stderr index 82324810ad..56acdfdabb 100644 --- a/testsuite/tests/th/TH_implicitParamsErr1.stderr +++ b/testsuite/tests/th/TH_implicitParamsErr1.stderr @@ -1,4 +1,4 @@ -TH_implicitParamsErr1.hs:5:3: error: +TH_implicitParamsErr1.hs:5:2: error: Implicit parameter binding only allowed in let or where When splicing a TH declaration: ?x = 1 diff --git a/testsuite/tests/th/TH_implicitParamsErr2.stderr b/testsuite/tests/th/TH_implicitParamsErr2.stderr index f93aa55a58..faa2a9e90b 100644 --- a/testsuite/tests/th/TH_implicitParamsErr2.stderr +++ b/testsuite/tests/th/TH_implicitParamsErr2.stderr @@ -1,5 +1,5 @@ -TH_implicitParamsErr2.hs:5:10: error: +TH_implicitParamsErr2.hs:5:9: error: • Implicit parameters mixed with other bindings When splicing a TH expression: let {?x = 1; y = 2} in y diff --git a/testsuite/tests/th/TH_implicitParamsErr3.stderr b/testsuite/tests/th/TH_implicitParamsErr3.stderr index fe3bf67259..a83ead7a0a 100644 --- a/testsuite/tests/th/TH_implicitParamsErr3.stderr +++ b/testsuite/tests/th/TH_implicitParamsErr3.stderr @@ -1,5 +1,5 @@ -TH_implicitParamsErr3.hs:5:16: error: +TH_implicitParamsErr3.hs:5:15: error: • Illegal variable name: ‘invalid name’ When splicing a TH expression: let ?invalid name = "hi" diff --git a/testsuite/tests/th/TH_invalid_add_top_decl.stderr b/testsuite/tests/th/TH_invalid_add_top_decl.stderr index 9124c2d669..0e8f6b66c2 100644 --- a/testsuite/tests/th/TH_invalid_add_top_decl.stderr +++ b/testsuite/tests/th/TH_invalid_add_top_decl.stderr @@ -1,5 +1,5 @@ -TH_invalid_add_top_decl.hs:5:3: +TH_invalid_add_top_decl.hs:5:2: error: Error in a declaration passed to addTopDecls: Empty stmt list in do-block When splicing a TH declaration: emptyDo = do diff --git a/testsuite/tests/th/TH_pragma.stderr b/testsuite/tests/th/TH_pragma.stderr index 1156adee27..0baf21c564 100644 --- a/testsuite/tests/th/TH_pragma.stderr +++ b/testsuite/tests/th/TH_pragma.stderr @@ -1,4 +1,4 @@ -TH_pragma.hs:(6,4)-(8,26): Splicing declarations +TH_pragma.hs:(6,2)-(8,28): Splicing declarations [d| foo :: Int -> Int {-# NOINLINE foo #-} foo x = x + 1 |] @@ -6,7 +6,7 @@ TH_pragma.hs:(6,4)-(8,26): Splicing declarations foo :: Int -> Int {-# NOINLINE foo #-} foo x = (x + 1) -TH_pragma.hs:(10,4)-(12,31): Splicing declarations +TH_pragma.hs:(10,2)-(12,33): Splicing declarations [d| bar :: Num a => a -> a {-# SPECIALISE INLINE [~1] bar :: Float -> Float #-} bar x = x * 10 |] diff --git a/testsuite/tests/th/TH_recover_warns.stderr b/testsuite/tests/th/TH_recover_warns.stderr index c92ee71bc9..24bfb76f1d 100644 --- a/testsuite/tests/th/TH_recover_warns.stderr +++ b/testsuite/tests/th/TH_recover_warns.stderr @@ -1,10 +1,10 @@ -TH_recover_warns.hs:(9,19)-(10,63): Splicing expression +TH_recover_warns.hs:(9,18)-(10,64): Splicing expression recover (stringE "splice failed") [| let x = "a" in let x = "b" in x |] ======> let x = "a" in let x = "b" in x -TH_recover_warns.hs:9:19: warning: [-Wunused-local-binds (in -Wextra, -Wunused-binds)] +TH_recover_warns.hs:9:18: warning: [-Wunused-local-binds (in -Wextra, -Wunused-binds)] Defined but not used: ‘x’ TH_recover_warns.hs:10:34: warning: [-Wunused-local-binds (in -Wextra, -Wunused-binds)] diff --git a/testsuite/tests/th/TH_repUnboxedTuples.stderr b/testsuite/tests/th/TH_repUnboxedTuples.stderr index 8439b12547..3687b77a0e 100644 --- a/testsuite/tests/th/TH_repUnboxedTuples.stderr +++ b/testsuite/tests/th/TH_repUnboxedTuples.stderr @@ -3,11 +3,3 @@ case (# 'b', GHC.Types.False #) of (# 'a', GHC.Types.True #) -> (# "One", 1 #) (# 'b', GHC.Types.False #) -> (# "Two", 2 #) (# _, _ #) -> (# "Three", 3 #) - -TH_repUnboxedTuples.hs:18:13: warning: [-Woverlapping-patterns (in -Wdefault)] - Pattern match is redundant - In a case alternative: (# 'a', True #) -> ... - -TH_repUnboxedTuples.hs:18:13: warning: [-Woverlapping-patterns (in -Wdefault)] - Pattern match is redundant - In a case alternative: (# _, _ #) -> ... diff --git a/testsuite/tests/th/TH_runIO.stderr b/testsuite/tests/th/TH_runIO.stderr index 5d5a4f2efc..50af621620 100644 --- a/testsuite/tests/th/TH_runIO.stderr +++ b/testsuite/tests/th/TH_runIO.stderr @@ -1,6 +1,6 @@ -TH_runIO.hs:12:7: - Exception when trying to run compile-time code: - user error (hi) - Code: runIO (fail "hi") - In the untyped splice: $(runIO (fail "hi")) +TH_runIO.hs:12:7: error: + • Exception when trying to run compile-time code: + user error (hi) + Code: (runIO (fail "hi")) + • In the untyped splice: $(runIO (fail "hi")) diff --git a/testsuite/tests/th/TH_spliceD1.stderr b/testsuite/tests/th/TH_spliceD1.stderr index 9e6fb5013a..77ae873562 100644 --- a/testsuite/tests/th/TH_spliceD1.stderr +++ b/testsuite/tests/th/TH_spliceD1.stderr @@ -1,6 +1,6 @@ -TH_spliceD1.hs:10:3: - Conflicting definitions for ‘c’ - Bound at: TH_spliceD1.hs:10:3-5 - TH_spliceD1.hs:10:3-5 - In an equation for ‘f’ +TH_spliceD1.hs:10:2: error: + • Conflicting definitions for ‘c’ + Bound at: TH_spliceD1.hs:10:2-6 + TH_spliceD1.hs:10:2-6 + • In an equation for ‘f’ diff --git a/testsuite/tests/th/TH_unresolvedInfix2.stderr b/testsuite/tests/th/TH_unresolvedInfix2.stderr index 4a5577f6fc..50d56a02ff 100644 --- a/testsuite/tests/th/TH_unresolvedInfix2.stderr +++ b/testsuite/tests/th/TH_unresolvedInfix2.stderr @@ -1,11 +1,11 @@ -TH_unresolvedInfix2.hs:14:11: - The operator ‘:+’ [infixl 6] of a section - must have lower precedence than that of the operand, - namely ‘:+’ [infixl 6] - in the section: ‘:+ N :+ N’ - In the untyped splice: - $(let - plus = conE '(:+) - n = conE 'N - in infixE Nothing plus (Just $ uInfixE n plus n)) +TH_unresolvedInfix2.hs:14:9: error: + • The operator ‘:+’ [infixl 6] of a section + must have lower precedence than that of the operand, + namely ‘:+’ [infixl 6] + in the section: ‘:+ N :+ N’ + • In the untyped splice: + $(let + plus = conE '(:+) + n = conE 'N + in infixE Nothing plus (Just $ uInfixE n plus n)) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index b63b0ceb01..9e07d5035b 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -486,6 +486,8 @@ test('T16976f', normal, compile_fail, ['']) test('T16976z', normal, compile_fail, ['']) test('T16980', normal, compile, ['']) test('T16980a', normal, compile_fail, ['']) +test('T17270a', extra_files(['T17270.hs']), multimod_compile, ['T17270', '-v0']) +test('T17270b', extra_files(['T17270.hs']), multimod_compile, ['T17270', '-fenable-th-splice-warnings -v0']) test('T17296', normal, compile, ['-v0']) test('T17380', normal, compile_fail, ['']) test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) diff --git a/testsuite/tests/typecheck/should_compile/tc163.hs b/testsuite/tests/typecheck/should_compile/tc163.hs index 21d8a72949..fb8682bc22 100644 --- a/testsuite/tests/typecheck/should_compile/tc163.hs +++ b/testsuite/tests/typecheck/should_compile/tc163.hs @@ -24,7 +24,7 @@ flop = \m' k -> mkM3' m' (\bm k1 -> error "urk") -- But if we give mkM3' the type -- forall a r. M3' a -> (forall b. ...) -> r --- everthing works fine. Very very delicate. +-- everything works fine. Very very delicate. ---------------- A more complex case ------------- bind :: M3 a -> (a -> M3 b) -> M3 b diff --git a/testsuite/tests/typecheck/should_compile/type_in_type_hole_fits.hs b/testsuite/tests/typecheck/should_compile/type_in_type_hole_fits.hs index 566f8aa102..982d7e596c 100644 --- a/testsuite/tests/typecheck/should_compile/type_in_type_hole_fits.hs +++ b/testsuite/tests/typecheck/should_compile/type_in_type_hole_fits.hs @@ -55,7 +55,7 @@ newtype Sorted (cpu :: AsympPoly) -- The minimum operational complexity -- Merge sort is O(N*Log(N)) on average in complexity, so that's the -- minimum complexity we promise to satisfy. Same goes with memory, which is --- O(N), and as we all know, mergesort is a stable sorting algoritm. +-- O(N), and as we all know, mergesort is a stable sorting algorithm. mergeSort :: (Ord a, n >=. O(N*.LogN), m >=. O(N), IsStable s) => [a] -> Sorted n m s a mergeSort = Sorted . sort diff --git a/testsuite/tests/typecheck/should_fail/T14761b.stderr b/testsuite/tests/typecheck/should_fail/T14761b.stderr index 08a319cde3..af557c4725 100644 --- a/testsuite/tests/typecheck/should_fail/T14761b.stderr +++ b/testsuite/tests/typecheck/should_fail/T14761b.stderr @@ -1,5 +1,2 @@ -T14761b.hs:5:21: error: - Strictness annotation applied to a compound type. - Did you mean to add parentheses? - !(Maybe Int) +T14761b.hs:5:19: error: Operator applied to too few arguments: ! diff --git a/testsuite/tests/typecheck/should_fail/T15527.stderr b/testsuite/tests/typecheck/should_fail/T15527.stderr index dd03a0a0ca..2b764caef9 100644 --- a/testsuite/tests/typecheck/should_fail/T15527.stderr +++ b/testsuite/tests/typecheck/should_fail/T15527.stderr @@ -1,4 +1,8 @@ -T15527.hs:4:6: error: - Pattern syntax in expression context: (.)@Int - Did you mean to enable TypeApplications? +T15527.hs:4:10: error: + Variable not in scope: + (@) + :: ((b0 -> c0) -> (a0 -> b0) -> a0 -> c0) + -> t0 -> (Int -> Int) -> (Int -> Int) -> Int -> Int + +T15527.hs:4:11: error: Data constructor not in scope: Int diff --git a/testsuite/tests/typecheck/should_fail/T7210.stderr b/testsuite/tests/typecheck/should_fail/T7210.stderr index 4d7cb38a4d..d0ca04a84e 100644 --- a/testsuite/tests/typecheck/should_fail/T7210.stderr +++ b/testsuite/tests/typecheck/should_fail/T7210.stderr @@ -1,5 +1,7 @@ -T7210.hs:5:20: error: - Strictness annotation applied to a compound type. - Did you mean to add parentheses? - !(IntMap Int) +T7210.hs:5:19: error: + • Unexpected strictness annotation: !IntMap + strictness annotation cannot appear nested inside a type + • In the type ‘!IntMap Int’ + In the definition of data constructor ‘C’ + In the data declaration for ‘T’ diff --git a/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs b/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs index 83b147e413..7c92fa9ab0 100644 --- a/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs +++ b/testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs @@ -441,7 +441,7 @@ mkPrimCon dt str cr = Constr { datatype = dt , conrep = cr , constring = str - , confields = error $ concat ["constrFields : ", (tycon dt), " is primative"] + , confields = error $ concat ["constrFields : ", (tycon dt), " is primitive"] , confixity = error "constrFixity" } diff --git a/typing_stubs.py b/typing_stubs.py deleted file mode 100644 index b2e3948043..0000000000 --- a/typing_stubs.py +++ /dev/null @@ -1,13 +0,0 @@ -# Stub definitions for things provided by the typing package -# for use by older Python versions. - -class Dummy: - def __index__(self, *args): - return None - -List = Dummy() -Tuple = Dummy() -Set = Dummy() -TextIO = Dummy() -Iterator = Dummy() -Newtype = lambda name, ty: ty diff --git a/utils/gen-dll/Main.hs b/utils/gen-dll/Main.hs index 39f8ed9c13..237a43016e 100644 --- a/utils/gen-dll/Main.hs +++ b/utils/gen-dll/Main.hs @@ -152,7 +152,7 @@ ar = AR_TOOL_BIN -- dll is 2^16-1, however Microsoft's lib.exe for some reason refuses to link -- up to this amount. The reason is likely that it adds some extra symbols in -- the generated dll, such as dllmain etc. So we reserve some space in the --- symbol table to accomodate this. This number is just purely randomly chosen. +-- symbol table to accommodate this. This number is just purely randomly chosen. #define SYMBOL_PADDING 10 usage :: IO () diff --git a/utils/genapply/Main.hs b/utils/genapply/Main.hs index 8c194f1ca0..a6d944efa4 100644 --- a/utils/genapply/Main.hs +++ b/utils/genapply/Main.hs @@ -38,7 +38,7 @@ import System.IO import Control.Arrow ((***)) -- ----------------------------------------------------------------------------- --- Argument kinds (rougly equivalent to PrimRep) +-- Argument kinds (roughly equivalent to PrimRep) data ArgRep = N -- non-ptr diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 3427a1ebae..ef8e284593 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -427,7 +427,7 @@ wrapOp :: String -> String wrapOp nm | isAlpha (head nm) = nm | otherwise = "(" ++ nm ++ ")" --- | Turn an identifer or operator into its infix form +-- | Turn an identifier or operator into its infix form asInfix :: String -> String asInfix nm | isAlpha (head nm) = "`" ++ nm ++ "`" | otherwise = nm @@ -857,7 +857,7 @@ ppType (TyApp (TyCon "ByteArray#") []) = "byteArrayPrimTy" ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy" ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy" ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy" -ppType (TyApp (TyCon "BCO#") []) = "bcoPrimTy" +ppType (TyApp (TyCon "BCO") []) = "bcoPrimTy" ppType (TyApp (TyCon "Compact#") []) = "compactPrimTy" ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is TysWiredIn's name for () diff --git a/utils/haddock b/utils/haddock -Subproject 1a685b213c6a1a1f2ea86826891eda1acbfecc8 +Subproject e91c892a2532ff6abc6d7639db6bad66278b1c0 diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index 70519600e9..e44fa7b95f 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -477,7 +477,7 @@ instance Monoid ModuleSummary where mappend = (<>) ------------------------------------------------------------------------------ --- global color pallete +-- global color palette red,green,yellow :: String red = "#f20913" diff --git a/utils/lndir/lndir-Xos.h b/utils/lndir/lndir-Xos.h index b423f6b641..6421d4a0bf 100644 --- a/utils/lndir/lndir-Xos.h +++ b/utils/lndir/lndir-Xos.h @@ -18,7 +18,7 @@ */ /* This is a collection of things to try and minimize system dependencies - * in a "signficant" number of source files. + * in a "significant" number of source files. */ #pragma once diff --git a/utils/unlit/unlit.c b/utils/unlit/unlit.c index 97f853b268..5a0e535109 100644 --- a/utils/unlit/unlit.c +++ b/utils/unlit/unlit.c @@ -20,7 +20,7 @@ * 1) Empty script files are not permitted. A file in which no lines * begin with `>' usually indicates a file in which the programmer * has forgotten about the literate script convention. - * 2) A line containing part of program definition (i.e. preceeded by `>') + * 2) A line containing part of program definition (i.e. preceded by `>') * cannot be used immediately before or after a comment line unless * the comment line is blank. This error usually indicates that * the `>' character has been omitted from a line in a section of @@ -166,7 +166,7 @@ static int egetc(FILE *istream) * Lines of type DEFN are copied to the output stream `ostream' * (without the leading DEFNCHAR). BLANK and TEXT lines are * replaced by empty (i.e. blank lines) in the output stream, so - * that error messages refering to line numbers in the output file + * that error messages referring to line numbers in the output file * can also be used to locate the corresponding line in the input * stream. */ @@ -11,7 +11,7 @@ https://gitlab.haskell.org/ghc/ghc/wikis/testing-patches for more information. Flags: - --no-clean don't make clean first, just carry on from + --no-clean don't clean first, just carry on from a previous interrupted validation run --testsuite-only don't build the compiler, just run the test suite --build-only don't test the compiler, just build it @@ -25,8 +25,10 @@ Flags: 2008-07-01: 14% slower than the default. --quiet More pretty build log. See Note [Default build system verbosity]. - --hadrian Build the compiler and run the tests through hadrian. - --stack Use Stack to build Hadrian and the Stage 1 compiler. + --legacy Build the compiler and run the tests through the legacy + make-based build system. + --stack Use Stack to build Hadrian and to provide the bootstrap + compiler. --help shows this usage help. validate runs 'make -j\$THREADS', where by default THREADS is the number of @@ -56,8 +58,9 @@ be_quiet=0 # heavy cost of xz, which is the typical default. The options are defined in # mk/config.mk.in tar_comp=gzip -use_hadrian=NO +use_hadrian=YES use_stack=NO +hadrian_build_root=_validatebuild while [ $# -gt 0 ] do @@ -86,9 +89,8 @@ do --quiet) be_quiet=1 ;; - --hadrian) - use_hadrian=YES - hadrian_build_root=_validatebuild + --legacy) + use_hadrian=NO ;; --stack) use_stack=YES |