Skip to content
Commits on Source (12)
  • Ben Gamari's avatar
    ErrUtils: Emit progress messages to eventlog · 1bef62c3
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    1bef62c3
  • Ben Gamari's avatar
    Emit GHC timing events to eventlog · ebfa3528
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    ebfa3528
  • Sven Tennie's avatar
    Typeset Big-O complexities with Tex-style notation (#16090) · 4186b410
    Sven Tennie authored and Marge Bot's avatar Marge Bot committed
    Use `\min` instead of `min` to typeset it as an operator.
    4186b410
  • Shayne Fletcher's avatar
    Make Extension derive Bounded · 9047f184
    Shayne Fletcher authored and Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan committed
    9047f184
  • Ben Gamari's avatar
    testsuite: Mark concprog001 as fragile · 0dde64f2
    Ben Gamari authored and Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan committed
    Due to #16604.
    0dde64f2
  • Alp Mestanogullari's avatar
    Hadrian: generate JUnit testsuite report in Linux CI job · 8f929388
    Alp Mestanogullari authored and Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan committed
    We also keep it as an artifact, like we do for non-Hadrian jobs, and list it
    as a junit report, so that the test results are reported in the GitLab UI for
    merge requests.
    8f929388
  • Vladislav Zavialov's avatar
    Pattern/expression ambiguity resolution · 52fc2719
    Vladislav Zavialov authored and Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan committed
    This patch removes 'EWildPat', 'EAsPat', 'EViewPat', and 'ELazyPat'
    from 'HsExpr' by using the ambiguity resolution system introduced
    earlier for the command/expression ambiguity.
    
    Problem: there are places in the grammar where we do not know whether we
    are parsing an expression or a pattern, for example:
    
    	do { Con a b <- x } -- 'Con a b' is a pattern
    	do { Con a b }      -- 'Con a b' is an expression
    
    Until we encounter binding syntax (<-) we don't know whether to parse
    'Con a b' as an expression or a pattern.
    
    The old solution was to parse as HsExpr always, and rejig later:
    
    	checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs)
    
    This meant polluting 'HsExpr' with pattern-related constructors. In
    other words, limitations of the parser were affecting the AST, and all
    other code (the renamer, the typechecker) had to deal with these extra
    constructors.
    
    We fix this abstraction leak by parsing into an overloaded
    representation:
    
    	class DisambECP b where ...
    	newtype ECP = ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }
    
    See Note [Ambiguous syntactic categories] for details.
    
    Now the intricacies of parsing have no effect on the hsSyn AST when it
    comes to the expression/pattern ambiguity.
    52fc2719
  • Ningning Xie's avatar
    Only skip decls with CUSKs with PolyKinds on (fix #16609) · 9b59e126
    Ningning Xie authored and Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan committed
    9b59e126
  • Ömer Sinan Ağacan's avatar
    Fix interface version number printing in --show-iface · 87bc954a
    Ömer Sinan Ağacan authored
    Before
    
        Version: Wanted [8, 0, 9, 0, 2, 0, 1, 9, 0, 4, 2, 5],
                 got    [8, 0, 9, 0, 2, 0, 1, 9, 0, 4, 2, 5]
    
    After
    
        Version: Wanted 809020190425,
                 got    809020190425
    87bc954a
  • Ryan Scott's avatar
    Make equality constraints in kinds invisible · cc495d57
    Ryan Scott authored and Ömer Sinan Ağacan's avatar Ömer Sinan Ağacan committed
    Issues #12102 and #15872 revealed something strange about the way GHC
    handles equality constraints in kinds: it treats them as _visible_
    arguments! This causes a litany of strange effects, from strange
    error messages
    (#12102 (comment 169035))
    to bizarre `Eq#`-related things leaking through to GHCi output, even
    without any special flags enabled.
    
    This patch is an attempt to contain some of this strangeness.
    In particular:
    
    * In `TcHsType.etaExpandAlgTyCon`, we propagate through the
      `AnonArgFlag`s of any `Anon` binders. Previously, we were always
      hard-coding them to `VisArg`, which meant that invisible binders
      (like those whose kinds were equality constraint) would mistakenly
      get flagged as visible.
    * In `ToIface.toIfaceAppArgsX`, we previously assumed that the
      argument to a `FunTy` always corresponding to a `Required`
      argument. We now dispatch on the `FunTy`'s `AnonArgFlag` and map
      `VisArg` to `Required` and `Inv...
    cc495d57
  • John Ericson's avatar
    Remove cGhcEnableTablesNextToCode · 777896a6
    John Ericson authored and John Ericson's avatar John Ericson committed
    Get "Tables next to code" from the settings file instead.
    777896a6
  • Joachim Breitner's avatar
    Make tablesNextToCode a proper dynamic flag (#15548) · 84cb3212
    Joachim Breitner authored and John Ericson's avatar John Ericson committed
    Summary:
    There is no more use of the TABLES_NEXT_TO_CODE CPP macro in
    `compiler/`. GHCI_TABLES_NEXT_TO_CODE is also removed entirely. The
    default value of `tablesNextToCode` is calculated as before, but now
    users of the GHCI API can modify this flag.
    
    That said, GHC still is hardcoded to define TABLES_NEXT_TO_CODE based on
    that default value. This is bad, but neccessary until the remaining uses
    of TABLES_NEXT_TO_CODE get it from make/Hadrian.
    
    Reviewers:
    
    Subscribers: TerrorJack, rwbarton, carter
    
    GHC Trac Issues: #15548
    
    Differential Revision: https://phabricator.haskell.org/D5082
    84cb3212
......@@ -144,16 +144,19 @@ lint-release-changelogs:
- ./boot
- ./configure $CONFIGURE_ARGS
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx binary-dist
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx test
- hadrian/build.cabal.sh -j`mk/detect-cpu-count.sh` --docs=no-sphinx test --summary-junit=./junit.xml
- mv _build/bindist/ghc*.tar.xz ghc.tar.xz
cache:
key: hadrian
paths:
- cabal-cache
artifacts:
when: always
reports:
junit: junit.xml
expire_in: 2 week
paths:
- ghc.tar.xz
- junit.xml
validate-x86_64-linux-deb8-hadrian:
extends: .validate-hadrian
......
......@@ -752,10 +752,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do
-- HsSyn constructs that just shouldn't be here:
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
ds_expr _ (EWildPat {}) = panic "dsExpr:EWildPat"
ds_expr _ (EAsPat {}) = panic "dsExpr:EAsPat"
ds_expr _ (EViewPat {}) = panic "dsExpr:EViewPat"
ds_expr _ (ELazyPat {}) = panic "dsExpr:ELazyPat"
ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
ds_expr _ (XExpr {}) = panic "dsExpr: XExpr"
......
......@@ -106,8 +106,6 @@ ifeq "$(GhcRtsWithLibdw)" "YES"
else
@echo 'cGhcRtsWithLibdw = False' >> $@
endif
@echo 'cGhcEnableTablesNextToCode :: String' >> $@
@echo 'cGhcEnableTablesNextToCode = "$(GhcEnableTablesNextToCode)"' >> $@
@echo 'cLeadingUnderscore :: String' >> $@
@echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@
@echo 'cLibFFI :: Bool' >> $@
......@@ -328,14 +326,6 @@ endif
ifeq "$(GhcWithInterpreter)" "YES"
compiler_stage2_CONFIGURE_OPTS += --flags=ghci
ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO"
# Should GHCI be building info tables in the TABLES_NEXT_TO_CODE style
# or not?
# XXX This should logically be a CPP option, but there doesn't seem to
# be a flag for that
compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DGHCI_TABLES_NEXT_TO_CODE
endif
# Should the debugger commands be enabled?
ifeq "$(GhciWithDebugger)" "YES"
compiler_stage2_CONFIGURE_OPTS += --ghc-option=-DDEBUGGER
......
......@@ -71,6 +71,8 @@ make_constr_itbls hsc_env cons =
descr = dataConIdentity dcon
r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
tables_next_to_code = tablesNextToCode dflags
r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really
conNo (tagForCon dflags dcon) descr)
return (getName dcon, ItblPtr r)
......@@ -870,18 +870,6 @@ instance ( a ~ GhcPass p
HsSpliceE _ x ->
[ toHie $ L mspan x
]
EWildPat _ -> []
EAsPat _ a b ->
[ toHie $ C Use a
, toHie b
]
EViewPat _ a b ->
[ toHie a
, toHie b
]
ELazyPat _ a ->
[ toHie a
]
XExpr _ -> []
instance ( a ~ GhcPass p
......
......@@ -624,32 +624,6 @@ data HsExpr p
-- See note [Pragma source text] in BasicTypes
(LHsExpr p)
---------------------------------------
-- These constructors only appear temporarily in the parser.
-- The renamer translates them into the Right Thing.
| EWildPat (XEWildPat p) -- wildcard
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-- For details on above see note [Api annotations] in ApiAnnotation
| EAsPat (XEAsPat p)
(Located (IdP p)) -- as pattern
(LHsExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
| EViewPat (XEViewPat p)
(LHsExpr p) -- view pattern
(LHsExpr p)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
-- For details on above see note [Api annotations] in ApiAnnotation
| ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern
---------------------------------------
-- Finally, HsWrap appears only in typechecker output
-- The contained Expr is *NOT* itself an HsWrap.
......@@ -761,10 +735,6 @@ type instance XStatic GhcTc = NameSet
type instance XTick (GhcPass _) = NoExt
type instance XBinTick (GhcPass _) = NoExt
type instance XTickPragma (GhcPass _) = NoExt
type instance XEWildPat (GhcPass _) = NoExt
type instance XEAsPat (GhcPass _) = NoExt
type instance XEViewPat (GhcPass _) = NoExt
type instance XELazyPat (GhcPass _) = NoExt
type instance XWrap (GhcPass _) = NoExt
type instance XXExpr (GhcPass _) = NoExt
......@@ -924,21 +894,12 @@ ppr_expr e@(HsApp {}) = ppr_apps e []
ppr_expr e@(HsAppType {}) = ppr_apps e []
ppr_expr (OpApp _ e1 op e2)
| Just pp_op <- should_print_infix (unLoc op)
| Just pp_op <- ppr_infix_expr (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v)
should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c))
should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f)
should_print_infix (HsUnboundVar _ h@TrueExprHole{})
= Just (pprInfixOcc (unboundVarOcc h))
should_print_infix (EWildPat _) = Just (text "`_`")
should_print_infix (HsWrap _ _ e) = should_print_infix e
should_print_infix _ = Nothing
pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens
pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear
......@@ -951,36 +912,30 @@ ppr_expr (OpApp _ e1 op e2)
ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e
ppr_expr (SectionL _ expr op)
= case unLoc op of
HsVar _ (L _ v) -> pp_infixly v
HsConLikeOut _ c -> pp_infixly (conLikeName c)
HsUnboundVar _ h@TrueExprHole{}
-> pp_infixly (unboundVarOcc h)
_ -> pp_prefixly
| Just pp_op <- ppr_infix_expr (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, text "x_ )"])
pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly v = (sep [pp_expr, pprInfixOcc v])
pp_infixly v = (sep [pp_expr, v])
ppr_expr (SectionR _ op expr)
= case unLoc op of
HsVar _ (L _ v) -> pp_infixly v
HsConLikeOut _ c -> pp_infixly (conLikeName c)
HsUnboundVar _ h@TrueExprHole{}
-> pp_infixly (unboundVarOcc h)
_ -> pp_prefixly
| Just pp_op <- ppr_infix_expr (unLoc op)
= pp_infixly pp_op
| otherwise
= pp_prefixly
where
pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
4 (pp_expr <> rparen)
pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc
pp_infixly v = sep [pprInfixOcc v, pp_expr]
pp_infixly v = sep [v, pp_expr]
ppr_expr (ExplicitTuple _ exprs boxity)
= tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
......@@ -1057,11 +1012,6 @@ ppr_expr (ExprWithTySig _ expr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
ppr_expr (EWildPat _) = char '_'
ppr_expr (ELazyPat _ e) = char '~' <> ppr e
ppr_expr (EAsPat _ (L _ v) e) = pprPrefixOcc v <> char '@' <> ppr e
ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e
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
......@@ -1110,6 +1060,14 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
ppr_expr (HsRecFld _ f) = ppr f
ppr_expr (XExpr x) = ppr x
ppr_infix_expr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
ppr_infix_expr (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c))
ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f)
ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h))
ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e
ppr_infix_expr _ = Nothing
ppr_apps :: (OutputableBndrId (GhcPass p))
=> HsExpr (GhcPass p)
-> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
......@@ -1196,10 +1154,6 @@ hsExprNeedsParens p = go
go (RecordUpd{}) = False
go (ExprWithTySig{}) = p >= sigPrec
go (ArithSeq{}) = False
go (EWildPat{}) = False
go (ELazyPat{}) = False
go (EAsPat{}) = False
go (EViewPat{}) = True
go (HsSCC{}) = p >= appPrec
go (HsWrap _ _ e) = go e
go (HsSpliceE{}) = False
......
......@@ -539,10 +539,6 @@ type family XStatic x
type family XTick x
type family XBinTick x
type family XTickPragma x
type family XEWildPat x
type family XEAsPat x
type family XEViewPat x
type family XELazyPat x
type family XWrap x
type family XXExpr x
......@@ -587,10 +583,6 @@ type ForallXExpr (c :: * -> Constraint) (x :: *) =
, c (XTick x)
, c (XBinTick x)
, c (XTickPragma x)
, c (XEWildPat x)
, c (XEAsPat x)
, c (XEViewPat x)
, c (XELazyPat x)
, c (XWrap x)
, c (XXExpr x)
)
......
......@@ -92,11 +92,12 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
(defaultDumpStyle dflags)
sd
QuietBinIFaceReading -> \_ -> return ()
wantedGot :: Outputable a => String -> a -> a -> IO ()
wantedGot what wanted got =
wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot what wanted got ppr' =
printer (text what <> text ": " <>
vcat [text "Wanted " <> ppr wanted <> text ",",
text "got " <> ppr got])
vcat [text "Wanted " <> ppr' wanted <> text ",",
text "got " <> ppr' got])
errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch what wanted got =
......@@ -111,7 +112,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
-- (This magic number does not change when we change
-- GHC interface file format)
magic <- get bh
wantedGot "Magic" (binaryInterfaceMagic dflags) magic
wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr
errorOnMismatch "magic number mismatch: old/corrupt interface file?"
(binaryInterfaceMagic dflags) magic
......@@ -129,12 +130,12 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
-- Check the interface file version and ways.
check_ver <- get bh
let our_ver = show hiVersion
wantedGot "Version" our_ver check_ver
wantedGot "Version" our_ver check_ver text
errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_way <- get bh
let way_descr = getWayDescr dflags
wantedGot "Way" way_descr check_way
wantedGot "Way" way_descr check_way ppr
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
getWithUserData ncu bh
......
......@@ -719,8 +719,9 @@ pprIfaceTyConBinders = sep . map go
-- See Note [Pretty-printing invisible arguments]
case vis of
AnonTCB VisArg -> ppr_bndr True
AnonTCB InvisArg -> ppr_bndr True -- Rare; just promoted GADT data constructors
-- Should we print them differently?
AnonTCB InvisArg -> char '@' <> braces (ppr_bndr False)
-- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.)
-- Should we print these differently?
NamedTCB Required -> ppr_bndr True
NamedTCB Specified -> char '@' <> ppr_bndr True
NamedTCB Inferred -> char '@' <> braces (ppr_bndr False)
......
......@@ -309,8 +309,14 @@ toIfaceAppArgsX fr kind ty_args
t' = toIfaceTypeX fr t
ts' = go (extendTCvSubst env tv t) res ts
go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps
= IA_Arg (toIfaceTypeX fr t) Required (go env res ts)
go env (FunTy { ft_af = af, ft_res = res }) (t:ts)
= IA_Arg (toIfaceTypeX fr t) argf (go env res ts)
where
argf = case af of
VisArg -> Required
InvisArg -> Inferred
-- It's rare for a kind to have a constraint argument, but
-- it can happen. See Note [AnonTCB InvisArg] in TyCon.
go env ty ts@(t1:ts1)
| not (isEmptyTCvSubst env)
......
......@@ -59,7 +59,6 @@ module DynFlags (
fFlags, fLangFlags, xFlags,
wWarningFlags,
dynFlagDependencies,
tablesNextToCode,
makeDynFlagsConsistent,
shouldUseColor,
shouldUseHexWordLiterals,
......@@ -880,6 +879,10 @@ data DynFlags = DynFlags {
integerLibrary :: IntegerLibrary,
-- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overriden
-- by GHC-API users. See Note [The integer library] in PrelNames
tablesNextToCode :: Bool,
-- ^ Determines whether we will be compiling info tables that reside just
-- before the entry code, or with an indirection to the entry code. See
-- TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h.
llvmTargets :: LlvmTargets,
llvmPasses :: LlvmPasses,
verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels]
......@@ -1353,7 +1356,10 @@ data Settings = Settings {
sOpt_lcc :: [String], -- LLVM: c compiler
sOpt_i :: [String], -- iserv options
sPlatformConstants :: PlatformConstants
sPlatformConstants :: PlatformConstants,
-- Formerly Config.hs, target specific
sTablesNextToCode :: Bool
}
targetPlatform :: DynFlags -> Platform
......@@ -1621,18 +1627,6 @@ defaultObjectTarget platform
| cGhcWithNativeCodeGen == "YES" = HscAsm
| otherwise = HscLlvm
tablesNextToCode :: DynFlags -> Bool
tablesNextToCode dflags
= mkTablesNextToCode (platformUnregisterised (targetPlatform dflags))
-- Determines whether we will be compiling
-- info tables that reside just before the entry code, or with an
-- indirection to the entry code. See TABLES_NEXT_TO_CODE in
-- includes/rts/storage/InfoTables.h.
mkTablesNextToCode :: Bool -> Bool
mkTablesNextToCode unregisterised
= not unregisterised && cGhcEnableTablesNextToCode == "YES"
data DynLibLoader
= Deployable
| SystemDependent
......@@ -1887,6 +1881,9 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
ghcLink = LinkBinary,
hscTarget = defaultHscTarget (sTargetPlatform mySettings),
integerLibrary = cIntegerLibraryType,
tablesNextToCode =
not (platformUnregisterised $ sTargetPlatform mySettings) &&
sTablesNextToCode mySettings,
verbosity = 0,
optLevel = 0,
debugLevel = 0,
......@@ -5621,7 +5618,7 @@ compilerInfo dflags
("Object splitting supported", showBool False),
("Have native code generator", cGhcWithNativeCodeGen),
("Support SMP", cGhcWithSMP),
("Tables next to code", cGhcEnableTablesNextToCode),
("Tables next to code", showBool $ sTablesNextToCode $ settings dflags),
("RTS ways", cGhcRTSWays),
("RTS expects libdw", showBool cGhcRtsWithLibdw),
-- Whether or not we support @-dynamic-too@
......
......@@ -81,6 +81,7 @@ import Data.IORef
import Data.Maybe ( fromMaybe )
import Data.Ord
import Data.Time
import Debug.Trace
import Control.Monad
import Control.Monad.IO.Class
import System.IO
......@@ -608,9 +609,10 @@ fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
= ifVerbose dflags 1 $
logOutput dflags (defaultUserStyle dflags) (text msg)
compilationProgressMsg dflags msg = do
traceEventIO $ "GHC progress: " ++ msg
ifVerbose dflags 1 $
logOutput dflags (defaultUserStyle dflags) (text msg)
showPass :: DynFlags -> String -> IO ()
showPass dflags what
......@@ -651,10 +653,12 @@ withTiming getDFlags what force_result action
if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags
then do liftIO $ logInfo dflags (defaultUserStyle dflags)
$ text "***" <+> what <> colon
liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:started:" <+> what
alloc0 <- liftIO getAllocationCounter
start <- liftIO getCPUTime
!r <- action
() <- pure $ force_result r
liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:finished:" <+> what
end <- liftIO getCPUTime
alloc1 <- liftIO getAllocationCounter
-- recall that allocation counter counts down
......
......@@ -184,6 +184,7 @@ initSysTools top_dir
targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
targetHasIdentDirective <- readSetting "target has .ident directive"
targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
tablesNextToCode <- getBooleanSetting "Tables next to code"
myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
-- On Windows, mingw is distributed with GHC,
-- so we look in TopDir/../mingw/bin,
......@@ -303,7 +304,8 @@ initSysTools top_dir
sOpt_lo = [],
sOpt_lc = [],
sOpt_i = [],
sPlatformConstants = platformConstants
sPlatformConstants = platformConstants,
sTablesNextToCode = tablesNextToCode
}
......
......@@ -58,7 +58,6 @@ module Lexer (
activeContext, nextIsEOF,
getLexState, popLexState, pushLexState,
ExtBits(..),
addWarning,
lexTokenStream,
AddAnn,mkParensApiAnn,
commentToAnnotation
......@@ -2493,6 +2492,9 @@ class Monad m => MonadP m where
-- more than one parse error per file.
--
addError :: SrcSpan -> SDoc -> m ()
-- | Add a warning to the accumulator.
-- Use 'getMessages' to get the accumulated warnings.
addWarning :: WarningFlag -> SrcSpan -> SDoc -> m ()
-- | Add a fatal error. This will be the last error reported by the parser, and
-- the parser will not produce any result, ending in a 'PFailed' state.
addFatalError :: SrcSpan -> SDoc -> m a
......@@ -2515,6 +2517,16 @@ instance MonadP P where
es' = es `snocBag` errormsg
in (ws, es')
in POk s{messages=m'} ()
addWarning option srcspan warning
= P $ \s@PState{messages=m, options=o} ->
let
m' d =
let (ws, es) = m d
warning' = makeIntoWarning (Reason option) $
mkWarnMsg d srcspan alwaysQualify warning
ws' = if warnopt option o then ws `snocBag` warning' else ws
in (ws', es)
in POk s{messages=m'} ()
addFatalError span msg =
addError span msg >> P PFailed
getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
......@@ -2524,20 +2536,6 @@ instance MonadP P where
addAnnotationOnly l a v
allocateComments l
-- | Add a warning to the accumulator.
-- Use 'getMessages' to get the accumulated warnings.
addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
= P $ \s@PState{messages=m, options=o} ->
let
m' d =
let (ws, es) = m d
warning' = makeIntoWarning (Reason option) $
mkWarnMsg d srcspan alwaysQualify warning
ws' = if warnopt option o then ws `snocBag` warning' else ws
in (ws', es)
in POk s{messages=m'} ()
addTabWarning :: RealSrcSpan -> P ()
addTabWarning srcspan
= P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
......
This diff is collapsed.
......@@ -13,8 +13,6 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RdrHsSyn (
......@@ -51,11 +49,11 @@ module RdrHsSyn (
-- Bunch of functions in the parser monad for
-- checking and constructing values
checkExpBlockArguments,
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat
checkPattern_msg,
bang_RDR,
isBangRdr,
isTildeRdr,
checkMonadComp, -- P (HsStmtContext RdrName)
......@@ -85,16 +83,19 @@ module RdrHsSyn (
warnStarIsType,
failOpFewArgs,
SumOrTuple (..), mkSumOrTuple,
SumOrTuple (..),
-- Expression/command ambiguity resolution
-- Expression/command/pattern ambiguity resolution
PV,
runPV,
ExpCmdP(ExpCmdP, runExpCmdPV),
runExpCmdP,
ExpCmdI(..),
ecFromExp,
ecFromCmd,
ECP(ECP, runECP_PV),
runECP_P,
DisambInfixOp(..),
DisambECP(..),
ecpFromExp,
ecpFromCmd,
PatBuilder,
patBuilderBang,
) where
......@@ -911,7 +912,7 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
++ occNameString occ))
check _ = panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: Outputable a => Located a -> P (Located a)
checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)
checkRecordSyntax lr@(dL->L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit
unless allowed $ addError loc $
......@@ -1056,117 +1057,80 @@ checkNoDocs msg ty = go ty
-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.
checkPattern :: LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)
checkPattern = runPV . checkLPat
checkPattern_msg :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs)
checkPattern_msg msg = runPV_msg msg . checkLPat
checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)
checkLPat :: LHsExpr GhcPs -> PV (LPat GhcPs)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e@(dL->L l _) = checkPat l e []
checkPat :: SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs]
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat loc (dL->L l e@(HsVar _ (dL->L _ c))) args
checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args
| isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
| not (null args) && patIsRec c =
localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
patFail l e
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 _ (HsApp _ f e)) args
checkPat loc (dL->L _ (PatBuilderApp f e)) args
= do p <- checkLPat e
checkPat loc f (p : args)
checkPat loc (dL->L _ e) []
= do p <- checkAPat loc e
return (cL loc p)
checkPat loc e _
= patFail loc (unLoc e)
= patFail loc (ppr e)
checkAPat :: SrcSpan -> HsExpr GhcPs -> PV (Pat GhcPs)
checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)
checkAPat loc e0 = do
nPlusKPatterns <- getBit NPlusKPatternsBit
case e0 of
EWildPat _ -> return (WildPat noExt)
HsVar _ x -> return (VarPat noExt x)
HsLit _ (HsStringPrim _ _) -- (#13260)
-> addFatalError loc (text "Illegal unboxed string literal in pattern:"
$$ ppr e0)
HsLit _ l -> return (LitPat noExt l)
PatBuilderPat p -> return p
PatBuilderVar x -> return (VarPat noExt x)
-- 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
HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing)
NegApp _ (dL->L l (HsOverLit _ pos_lit)) _
-> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr))
PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing)
SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x)
| bang == bang_RDR
PatBuilderBang lb e -- (! x)
-> do { hintBangPat loc e0
; e' <- checkLPat e
; addAnnotation loc AnnBang lb
; return (BangPat noExt e') }
ELazyPat _ e -> checkLPat e >>= (return . (LazyPat noExt))
EAsPat _ n e -> checkLPat e >>= (return . (AsPat noExt) n)
-- view pattern is well-formed if the pattern is
EViewPat _ expr patE -> checkLPat patE >>=
(return . (\p -> ViewPat noExt expr p))
ExprWithTySig _ e t -> do e <- checkLPat e
return (SigPat noExt e t)
-- n+k patterns
OpApp _ (dL->L nloc (HsVar _ (dL->L _ n)))
(dL->L _ (HsVar _ (dL->L _ plus)))
(dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}})))
PatBuilderOpApp
(dL->L nloc (PatBuilderVar (dL->L _ n)))
(dL->L _ plus)
(dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| nPlusKPatterns && (plus == plus_RDR)
-> return (mkNPlusKPat (cL nloc n) (cL lloc lit))
OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r
| isDataOcc (rdrNameOcc c) -> do
PatBuilderOpApp l (dL->L cl c) r
| isRdrDataCon c -> do
l <- checkLPat l
r <- checkLPat r
return (ConPatIn (cL cl c) (InfixCon l r))
OpApp {} -> patFail loc e0
ExplicitList _ _ es -> do ps <- mapM checkLPat es
return (ListPat noExt ps)
HsPar _ e -> checkLPat e >>= (return . (ParPat noExt))
ExplicitTuple _ es b
| all tupArgPresent es -> do ps <- mapM checkLPat
[e | (dL->L _ (Present _ e)) <- es]
return (TuplePat noExt ps b)
| otherwise -> addFatalError loc (text "Illegal tuple section in pattern:"
$$ ppr e0)
ExplicitSum _ alt arity expr -> do
p <- checkLPat expr
return (SumPat noExt p alt arity)
RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd }
-> do fs <- mapM checkPatField fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsSpliceE _ s | not (isTypedSplice s)
-> return (SplicePat noExt s)
_ -> patFail loc e0
PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExt))
_ -> patFail loc (ppr e0)
placeHolderPunRhs :: LHsExpr GhcPs
placeHolderPunRhs :: DisambECP b => PV (Located b)
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when
-- debugging
placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR))
placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR)
plus_RDR, bang_RDR, pun_RDR :: RdrName
plus_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
bang_RDR = mkUnqual varName (fsLit "!") -- Hack
pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
isBangRdr, isTildeRdr :: RdrName -> Bool
......@@ -1174,31 +1138,30 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
isBangRdr _ = False
isTildeRdr = (==eqTyCon_RDR)
checkPatField :: LHsRecField GhcPs (LHsExpr GhcPs)
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 }))
patFail :: SrcSpan -> HsExpr GhcPs -> PV a
patFail :: SrcSpan -> SDoc -> PV a
patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec")
---------------------------------------------------------------------------
-- Check Equation Syntax
checkValDef :: SrcStrictness
-> LHsExpr GhcPs
-> Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkValDef _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= checkPatBind (cL (combineLocs lhs sig)
(ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss
= do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat
checkPatBind lhs' grhss
checkValDef strictness lhs Nothing g@(dL->L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
......@@ -1206,14 +1169,16 @@ checkValDef strictness lhs Nothing g@(dL->L l (_,grhss))
Just (fun, is_infix, pats, ann) ->
checkFunBind strictness ann (getLoc lhs)
fun is_infix pats (cL l grhss)
Nothing -> checkPatBind lhs g }
Nothing -> do
lhs' <- checkPattern lhs
checkPatBind lhs' g }
checkFunBind :: SrcStrictness
-> [AddAnn]
-> SrcSpan
-> Located RdrName
-> LexicalFixity
-> [LHsExpr GhcPs]
-> [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)
......@@ -1242,13 +1207,11 @@ makeFunBind fn ms
fun_co_fn = idHsWrapper,
fun_tick = [] }
checkPatBind :: LHsExpr GhcPs
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
checkPatBind lhs (dL->L _ (_,grhss))
= do { lhs <- checkPattern lhs
; return ([],PatBind noExt lhs grhss
([],[])) }
= return ([],PatBind noExt lhs grhss ([],[]))
checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
......@@ -1282,10 +1245,10 @@ checkValSigLhs lhs@(dL->L l _)
default_RDR = mkUnqual varName (fsLit "default")
pattern_RDR = mkUnqual varName (fsLit "pattern")
checkDoAndIfThenElse'
checkDoAndIfThenElse
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
=> a -> Bool -> b -> Bool -> c -> PV ()
checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr
checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit
unless doAndIfThenElse $ do
......@@ -1303,20 +1266,21 @@ checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr
-- The parser left-associates, so there should
-- not be any OpApps inside the e's
splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs])
splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)])
-- Splits (f ! g a b) into (f, [(! g), a, b])
splitBang (dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg))
| op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns)
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 bang arg1
l' = combineLocs op arg1
(arg1,argns) = split_bang r_arg []
split_bang (dL->L _ (HsApp _ f e)) es = split_bang f (e:es)
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 :: LHsExpr GhcPs
-> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn]))
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
--
......@@ -1331,17 +1295,15 @@ isFunLhs :: LHsExpr GhcPs
isFunLhs e = go e [] []
where
go (dL->L loc (HsVar _ (dL->L _ f))) es ann
go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann
| not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann))
go (dL->L _ (HsApp _ f e)) es ann = go f (e:es) ann
go (dL->L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
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 _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang)))
(dL->L l (HsVar _ (L _ var))))) [] ann
| bang == bang_RDR
, not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann))
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
......@@ -1356,7 +1318,7 @@ isFunLhs e = go e [] []
-- ToDo: what about this?
-- x + 1 `op` y = ...
go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann
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
......@@ -1370,8 +1332,8 @@ isFunLhs e = go e [] []
Just (op', Infix, j : k : es', ann')
-> return (Just (op', Infix, j : op_app : es', ann'))
where
op_app = cL loc (OpApp noExt k
(cL loc' (HsVar noExt (cL loc' op))) r)
op_app = cL loc (PatBuilderOpApp k
(cL loc' op) r)
_ -> return Nothing }
go _ _ _ = return Nothing
......@@ -1856,7 +1818,7 @@ mergeDataCon all_xs =
-- If the flag MonadComprehensions is set, return a 'MonadComp' context,
-- otherwise use the usual 'ListComp' context
checkMonadComp :: P (HsStmtContext Name)
checkMonadComp :: PV (HsStmtContext Name)
checkMonadComp = do
monadComprehensions <- getBit MonadComprehensionsBit
return $ if monadComprehensions
......@@ -1864,96 +1826,373 @@ checkMonadComp = do
else ListComp
-- -------------------------------------------------------------------------
-- Expression/command ambiguity (arrow syntax).
-- Expression/command/pattern ambiguity.
-- See Note [Ambiguous syntactic categories]
--
-- ExpCmdP as defined is isomorphic to a pair of parsers:
--
-- data ExpCmdP = ExpCmdP { expP :: PV (LHsExpr GhcPs)
-- , cmdP :: PV (LHsCmd GhcPs) }
--
-- See Note [Parser-Validator]
-- See Note [Ambiguous syntactic categories]
newtype ExpCmdP =
ExpCmdP { runExpCmdPV :: forall b. ExpCmdI b => PV (Located (b GhcPs)) }
newtype ECP =
ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }
runExpCmdP :: ExpCmdI b => ExpCmdP -> P (Located (b GhcPs))
runExpCmdP p = runPV (runExpCmdPV p)
runECP_P :: DisambECP b => ECP -> P (Located b)
runECP_P p = runPV (runECP_PV p)
ecFromExp :: LHsExpr GhcPs -> ExpCmdP
ecFromExp a = ExpCmdP (ecFromExp' a)
ecpFromExp :: LHsExpr GhcPs -> ECP
ecpFromExp a = ECP (ecpFromExp' a)
ecFromCmd :: LHsCmd GhcPs -> ExpCmdP
ecFromCmd a = ExpCmdP (ecFromCmd' a)
ecpFromCmd :: LHsCmd GhcPs -> ECP
ecpFromCmd a = ECP (ecpFromCmd' a)
-- | Disambiguate infix operators.
-- See Note [Ambiguous syntactic categories]
class DisambInfixOp b where
checkIfBang :: b -> Bool
mkHsVarOpPV :: Located RdrName -> PV (Located b)
mkHsConOpPV :: Located RdrName -> PV (Located b)
mkHsInfixHolePV :: SrcSpan -> PV (Located b)
instance p ~ GhcPs => DisambInfixOp (HsExpr p) where
checkIfBang (HsVar _ (unLoc -> op)) = isBangRdr op
checkIfBang _ = False
mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExt v)
mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExt v)
mkHsInfixHolePV l = return $ cL l hsHoleExpr
instance DisambInfixOp RdrName where
checkIfBang = isBangRdr
mkHsConOpPV (dL->L l v) = return $ cL l v
mkHsVarOpPV (dL->L l v) = return $ cL l v
mkHsInfixHolePV l =
addFatalError l $ text "Invalid infix hole, expected an infix operator"
-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are
-- parsing an expression, a command, or a pattern.
-- See Note [Ambiguous syntactic categories]
class ExpCmdI b where
class b ~ (Body b) GhcPs => DisambECP b where
-- | See Note [Body in DisambECP]
type Body b :: * -> *
-- | Return a command without ambiguity, or fail in a non-command context.
ecFromCmd' :: LHsCmd GhcPs -> PV (Located (b GhcPs))
ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b)
-- | Return an expression without ambiguity, or fail in a non-expression context.
ecFromExp' :: LHsExpr GhcPs -> PV (Located (b GhcPs))
ecpFromExp' :: LHsExpr GhcPs -> PV (Located b)
-- | Disambiguate "\... -> ..." (lambda)
ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)
-- | Disambiguate "let ... in ..."
ecHsLet :: LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs
mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b)
-- | Infix operator representation
type InfixOp b
-- | Bring superclass constraints on FunArg into scope.
-- See Note [UndecidableSuperClasses for associated types]
superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b)
-- | Disambiguate "f # x" (infix operator)
ecOpApp :: Located (b GhcPs) -> LHsExpr GhcPs -> Located (b GhcPs) -> b GhcPs
mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b)
-- | Disambiguate "case ... of ..."
ecHsCase :: LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs
mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b)
-- | Function argument representation
type FunArg b
-- | Bring superclass constraints on FunArg into scope.
-- See Note [UndecidableSuperClasses for associated types]
superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b)
-- | Disambiguate "f x" (function application)
ecHsApp :: Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs
mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b)
-- | Disambiguate "if ... then ... else ..."
ecHsIf :: LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs
mkHsIfPV :: SrcSpan
-> LHsExpr GhcPs
-> Bool -- semicolon?
-> Located b
-> Bool -- semicolon?
-> Located b
-> PV (Located b)
-- | Disambiguate "do { ... }" (do notation)
ecHsDo :: Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs
mkHsDoPV :: SrcSpan -> Located [LStmt GhcPs (Located b)] -> PV (Located b)
-- | Disambiguate "( ... )" (parentheses)
ecHsPar :: Located (b GhcPs) -> b GhcPs
-- | Check if the argument requires -XBlockArguments.
checkBlockArguments :: Located (b GhcPs) -> PV ()
-- | Check if -XDoAndIfThenElse is enabled.
checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs)
-> Bool -> Located (b GhcPs) -> PV ()
instance ExpCmdI HsCmd where
ecFromCmd' = return
ecFromExp' (dL-> L l e) =
addFatalError l $
text "Parse error in command:" <+> ppr e
ecHsLam = HsCmdLam noExt
ecHsLet = HsCmdLet noExt
ecOpApp c1 op c2 =
let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in
HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2]
ecHsCase = HsCmdCase noExt
ecHsApp = HsCmdApp noExt
ecHsIf = mkHsCmdIf
ecHsDo = HsCmdDo noExt
ecHsPar = HsCmdPar noExt
checkBlockArguments = checkCmdBlockArguments
checkDoAndIfThenElse = checkDoAndIfThenElse'
instance ExpCmdI HsExpr where
ecFromCmd' (dL -> L l c) = do
mkHsParPV :: SrcSpan -> Located b -> PV (Located b)
-- | Disambiguate a variable "f" or a data constructor "MkF".
mkHsVarPV :: Located RdrName -> PV (Located b)
-- | Disambiguate a monomorphic literal
mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)
-- | Disambiguate an overloaded literal
mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b)
-- | Disambiguate a wildcard
mkHsWildCardPV :: SrcSpan -> PV (Located b)
-- | Disambiguate "a :: t" (type annotation)
mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
-- | Disambiguate "[a,b,c]" (list syntax)
mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b)
-- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)
mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b)
-- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)
mkHsRecordPV ::
SrcSpan ->
SrcSpan ->
Located b ->
([LHsRecField GhcPs (Located b)], Maybe SrcSpan) ->
PV (Located b)
-- | Disambiguate "-a" (negation)
mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b)
-- | Disambiguate "(# a)" (right operator section)
mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b)
-- | Disambiguate "(a -> b)" (view pattern)
mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b)
-- | Disambiguate "a@b" (as-pattern)
mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b)
-- | Disambiguate "~a" (lazy pattern)
mkHsLazyPatPV :: 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Assume we have a class C with an associated type T:
class C a where
type T a
...
If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:
{-# LANGUAGE UndecidableSuperClasses #-}
class C (T a) => C a where
type T a
...
Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes
making GHC loop. The workaround is to bring this constraint into scope
manually with a helper method:
class C a where
type T a
superT :: (C (T a) => r) -> r
In order to avoid ambiguous types, 'r' must mention 'a'.
For consistency, we use this approach for all constraints on associated types,
even when -XUndecidableSuperClasses are not required.
-}
{- Note [Body in DisambECP]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that
require their argument to take a form of (body GhcPs) for some (body :: * ->
*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the
superclass constraints of DisambECP.
The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop
this requirement. It is possible and would allow removing the type index of
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
ecpFromCmd' = return
ecpFromExp' (dL-> L l e) = cmdFail l (ppr e)
mkHsLamPV l mg = return $ cL l (HsCmdLam noExt mg)
mkHsLetPV l bs e = return $ cL l (HsCmdLet noExt bs e)
type InfixOp (HsCmd p) = HsExpr p
superInfixOp m = m
mkHsOpAppPV l c1 op c2 = do
let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c
return $ cL l $ HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2]
mkHsCasePV l c mg = return $ cL l (HsCmdCase noExt c mg)
type FunArg (HsCmd p) = HsExpr p
superFunArg m = m
mkHsAppPV l c e = do
checkCmdBlockArguments c
checkExpBlockArguments e
return $ cL l (HsCmdApp noExt 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 noExt stmts)
mkHsParPV l c = return $ cL l (HsCmdPar noExt 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)
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)
mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $
ppr a <+> ppr (mk_rec_fields fbinds ddLoc)
mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)
mkHsSectionR_PV l op c = cmdFail l $
let pp_op = fromMaybe (panic "cannot print infix operator")
(ppr_infix_expr (unLoc op))
in pp_op <> ppr c
mkHsViewPatPV l a b = cmdFail l $
ppr a <+> text "->" <+> ppr b
mkHsAsPatPV l v c = cmdFail l $
pprPrefixOcc (unLoc v) <> text "@" <> ppr c
mkHsLazyPatPV 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
addError l $ vcat
[ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ]
return (cL l hsHoleExpr)
ecFromExp' = return
ecHsLam = HsLam noExt
ecHsLet = HsLet noExt
ecOpApp = OpApp noExt
ecHsCase = HsCase noExt
ecHsApp = HsApp noExt
ecHsIf = mkHsIf
ecHsDo = HsDo noExt DoExpr
ecHsPar = HsPar noExt
checkBlockArguments = checkExpBlockArguments
checkDoAndIfThenElse = checkDoAndIfThenElse'
ecpFromExp' = return
mkHsLamPV l mg = return $ cL l (HsLam noExt mg)
mkHsLetPV l bs c = return $ cL l (HsLet noExt bs c)
type InfixOp (HsExpr p) = HsExpr p
superInfixOp m = m
mkHsOpAppPV l e1 op e2 = do
return $ cL l $ OpApp noExt e1 op e2
mkHsCasePV l e mg = return $ cL l (HsCase noExt e mg)
type FunArg (HsExpr p) = HsExpr p
superFunArg m = m
mkHsAppPV l e1 e2 = do
checkExpBlockArguments e1
checkExpBlockArguments e2
return $ cL l (HsApp noExt 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 noExt DoExpr stmts)
mkHsParPV l e = return $ cL l (HsPar noExt e)
mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExt v)
mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExt a)
mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExt a)
mkHsWildCardPV l = return $ cL l hsHoleExpr
mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExt a (mkLHsSigWcType sig))
mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExt Nothing xs)
mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExt) 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 noExt a noSyntaxExpr)
mkHsSectionR_PV l op e = return $ cL l (SectionR noExt 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
mkSumOrTuplePV = mkSumOrTupleExpr
patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
patSynErr l e explanation =
do { addError l $
sep [text "Pattern syntax in expression context:",
nest 4 (ppr e)] $$
explanation
; return (cL l hsHoleExpr) }
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (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 p ~ GhcPs => Outputable (PatBuilder p) 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
ppr (PatBuilderVar v) = ppr v
ppr (PatBuilderOverLit l) = ppr l
instance p ~ GhcPs => DisambECP (PatBuilder p) where
type Body (PatBuilder p) = PatBuilder
ecpFromCmd' (dL-> L l c) =
addFatalError l $
text "Command syntax in pattern:" <+> ppr c
ecpFromExp' (dL-> L l e) =
addFatalError l $
text "Expression syntax in pattern:" <+> ppr e
mkHsLamPV l _ = addFatalError l $
text "Lambda-syntax in pattern." $$
text "Pattern matching on functions is not possible."
mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"
type InfixOp (PatBuilder p) = RdrName
superInfixOp m = m
mkHsOpAppPV l p1 op p2 = return $ cL l $ PatBuilderOpApp p1 op p2
mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"
type FunArg (PatBuilder p) = PatBuilder p
superFunArg m = m
mkHsAppPV l p1 p2 = return $ cL 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
checkUnboxedStringLitPat lit
return $ cL l (PatBuilderPat (LitPat noExt a))
mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a)
mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExt))
mkHsTySigPV l b sig = do
p <- checkLPat b
return $ cL l (PatBuilderPat (SigPat noExt p (mkLHsSigWcType sig)))
mkHsExplicitListPV l xs = do
ps <- traverse checkLPat xs
return (cL l (PatBuilderPat (ListPat noExt ps)))
mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExt 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
lit <- case p of
PatBuilderOverLit pos_lit -> return (cL 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)
mkHsViewPatPV l a b = do
p <- checkLPat b
return $ cL l (PatBuilderPat (ViewPat noExt a p))
mkHsAsPatPV l v e = do
p <- checkLPat e
return $ cL l (PatBuilderPat (AsPat noExt v p))
mkHsLazyPatPV l e = do
p <- checkLPat e
return $ cL l (PatBuilderPat (LazyPat noExt p))
mkSumOrTuplePV = mkSumOrTuplePat
checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
checkUnboxedStringLitPat (dL->L loc lit) =
case lit of
HsStringPrim _ _ -- Trac #13260
-> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)
_ -> return ()
mkPatRec ::
Located (PatBuilder GhcPs) ->
HsRecFields GhcPs (Located (PatBuilder GhcPs)) ->
PV (PatBuilder GhcPs)
mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
| isRdrDataCon (unLoc c)
= do fs <- mapM checkPatField fs
return (PatBuilderPat (ConPatIn c (RecCon (HsRecFields fs dd))))
mkPatRec p _ =
addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
{- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -2008,9 +2247,19 @@ concerns local to the parser, and does not require duplication of hsSyn types,
or an extra pass over the entire AST, is to parse into an overloaded
parser-validator (a so-called tagless final encoding):
class ExpCmdI b where ...
instance ExpCmdI HsCmd where ...
instance ExpCmdI HsExp where ...
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 ...
The 'DisambECP' class contains functions to build and validate 'b'. For example,
to add parentheses we have:
mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)
'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for
expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,
see Note [PatBuilder]).
Consider the 'alts' production used to parse case-of alternatives:
......@@ -2018,9 +2267,9 @@ Consider the 'alts' production used to parse case-of alternatives:
: alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
We abstract over LHsExpr, and it becomes:
We abstract over LHsExpr GhcPs, and it becomes:
alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }
alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }
: alts1 { $1 >>= \ $1 ->
return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts { $2 >>= \ $2 ->
......@@ -2028,9 +2277,9 @@ We abstract over LHsExpr, and it becomes:
Compared to the initial definition, the added bits are:
forall b. ExpCmdI b => PV ( ... ) -- in the type signature
$1 >>= \ $1 -> return $ -- in one reduction rule
$2 >>= \ $2 -> return $ -- in another reduction rule
forall b. DisambECP b => PV ( ... ) -- in the type signature
$1 >>= \ $1 -> return $ -- in one reduction rule
$2 >>= \ $2 -> return $ -- in another reduction rule
The overhead is constant relative to the size of the rest of the reduction
rule, so this approach scales well to large parser productions.
......@@ -2316,11 +2565,80 @@ thread 'tag' explicitly:
| ';' alts { $2 >>= \ $2 ->
return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }
This encoding works well enough for two cases (Exp vs Cmd), but it does not scale well to
more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities.
This encoding works well enough, but introduces an extra GADT unlike the
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,
so we introduce the notion of a PatBuilder.
Consider a pattern like this:
Con a b c
We parse arguments to "Con" one at a time in the fexp aexp parser production,
building the result with mkHsAppPV, so the intermediate forms are:
1. Con
2. Con a
3. Con a b
4. Con a b c
In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like
this (pseudocode):
1. "Con"
2. HsApp "Con" "a"
3. HsApp (HsApp "Con" "a") "b"
3. HsApp (HsApp (HsApp "Con" "a") "b") "c"
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:
a `Con` b = ...
a `fun` b = ...
How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We
learn this by inspecting an intermediate representation in 'isFunLhs' and
seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate
representation capable of representing both a FunBind and a PatBind, so Pat is
insufficient.
PatBuilder is an extension of Pat that is capable of representing intermediate
parsing results for patterns and function bindings:
data PatBuilder p
= PatBuilderPat (Pat p)
| PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))
| PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))
...
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'.
-}
---------------------------------------------------------------------------
-- Miscellaneous utilities
......@@ -2342,7 +2660,7 @@ mkRecConstrOrUpdate
:: LHsExpr GhcPs
-> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> P (HsExpr GhcPs)
-> PV (HsExpr GhcPs)
mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
| isRdrDataCon c
......@@ -2680,6 +2998,8 @@ localPV_msg f (PV m) = PV (local f m)
instance MonadP PV where
addError srcspan msg =
PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg)
addWarning option srcspan msg =
PV $ ReaderT $ \_ -> addWarning option srcspan msg
addFatalError srcspan msg =
PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg)
getBit ext =
......@@ -2762,35 +3082,67 @@ the error messages.
-}
-- | Hint about bang patterns, assuming @BangPatterns@ is off.
hintBangPat :: SrcSpan -> HsExpr GhcPs -> PV ()
hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV ()
hintBangPat span e = do
bang_on <- getBit BangPatBit
unless bang_on $
addFatalError span
(text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
data SumOrTuple
= Sum ConTag Arity (LHsExpr GhcPs)
| Tuple [LHsTupArg GhcPs]
data SumOrTuple b
= Sum ConTag Arity (Located b)
| Tuple [Located (Maybe (Located b))]
pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc
pprSumOrTuple boxity = \case
Sum alt arity e ->
parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)
<+> parClose
Tuple xs ->
parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)
<> parClose
where
ppr_bars n = hsep (replicate n (Outputable.char '|'))
(parOpen, parClose) =
case boxity of
Boxed -> (text "(", text ")")
Unboxed -> (text "(#", text "#)")
mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs)
mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)
-- Tuple
mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity)
mkSumOrTupleExpr l boxity (Tuple es) =
return $ cL l (ExplicitTuple noExt (map toTupArg es) boxity)
where
toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs
toTupArg = mapLoc (maybe missingTupArg (Present noExt))
-- Sum
mkSumOrTuple Unboxed _ (Sum alt arity e) =
return (ExplicitSum noExt alt arity e)
mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) =
mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
return $ cL l (ExplicitSum noExt alt arity e)
mkSumOrTupleExpr l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(ppr_boxed_sum alt arity e))
(pprSumOrTuple Boxed a))
mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))
-- Tuple
mkSumOrTuplePat l boxity (Tuple ps) = do
ps' <- traverse toTupPat ps
return $ cL l (PatBuilderPat (TuplePat noExt ps' boxity))
where
ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc
ppr_boxed_sum alt arity e =
text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)
<+> text ")"
toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
toTupPat (dL -> L l p) = case p of
Nothing -> addFatalError l (text "Tuple section in pattern context")
Just p' -> checkLPat p'
ppr_bars n = hsep (replicate n (Outputable.char '|'))
-- Sum
mkSumOrTuplePat l Unboxed (Sum alt arity p) = do
p' <- checkLPat p
return $ cL l (PatBuilderPat (SumPat noExt p' alt arity))
mkSumOrTuplePat l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2
(pprSumOrTuple Boxed a))
mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y =
......
......@@ -140,6 +140,9 @@ rnExpr (HsVar _ (L l v))
rnExpr (HsIPVar x v)
= return (HsIPVar x v, emptyFVs)
rnExpr (HsUnboundVar x v)
= return (HsUnboundVar x v, emptyFVs)
rnExpr (HsOverLabel x _ v)
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
......@@ -345,24 +348,6 @@ rnExpr (ArithSeq x _ seq)
else
return (ArithSeq x Nothing new_seq, fvs) }
{-
These three are pattern syntax appearing in expressions.
Since all the symbols are reservedops we can simply reject them.
We return a (bogus) EWildPat in each case.
-}
rnExpr (EWildPat _) = return (hsHoleExpr, emptyFVs) -- "_" is just a hole
rnExpr e@(EAsPat {})
= do { opt_TypeApplications <- xoptM LangExt.TypeApplications
; let msg | opt_TypeApplications
= "Type application syntax requires a space before '@'"
| otherwise
= "Did you mean to enable TypeApplications?"
; patSynErr e (text msg)
}
rnExpr e@(EViewPat {}) = patSynErr e empty
rnExpr e@(ELazyPat {}) = patSynErr e empty
{-
************************************************************************
* *
......@@ -415,9 +400,6 @@ rnExpr (HsProc x pat body)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-- HsWrap
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
----------------------
-- See Note [Parsing sections] in Parser.y
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
......@@ -2087,12 +2069,6 @@ sectionErr expr
= hang (text "A section must be enclosed in parentheses")
2 (text "thus:" <+> (parens (ppr expr)))
patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)
patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
nest 4 (ppr e)] $$
explanation)
; return (EWildPat noExt, emptyFVs) }
badIpBinds :: Outputable a => SDoc -> a -> SDoc
badIpBinds what binds
= hang (text "Implicit-parameter bindings illegal in" <+> what)
......
......@@ -2368,13 +2368,13 @@ etaExpandAlgTyCon tc_bndrs kind
= case splitPiTy_maybe kind of
Nothing -> (reverse acc, substTy subst kind)
Just (Anon _ arg, kind')
Just (Anon af arg, kind')
-> go loc occs' uniqs' subst' (tcb : acc) kind'
where
arg' = substTy subst arg
tv = mkTyVar (mkInternalName uniq occ loc) arg'
subst' = extendTCvInScope subst tv
tcb = Bndr tv (AnonTCB VisArg)
tcb = Bndr tv (AnonTCB af)
(uniq:uniqs') = uniqs
(occ:occs') = occs
......
......@@ -3662,10 +3662,6 @@ exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e
exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e
exprCtOrigin (EWildPat {}) = panic "exprCtOrigin EWildPat"
exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat"
exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat"
exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat"
exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap"
exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr"
......
......@@ -288,7 +288,7 @@ we can get away with this is because we have more systematic TYPE r
inference, which means that we can do unification between kinds that
aren't lifted (this historically was not true.)
The downside of not directly reading off the kinds off the RHS of
The downside of not directly reading off the kinds of the RHS of
type synonyms in topological order is that we don't transparently
support making synonyms of types with higher-rank kinds. But
you can always specify a CUSK directly to make this work out.
......@@ -314,6 +314,23 @@ This gets us more polymorphism than we would otherwise get, similar
(but implemented strangely differently from) the treatment of type
signatures in value declarations.
However, we only want to do so when we have PolyKinds.
When we have NoPolyKinds, we don't skip those decls, because we have defaulting
(#16609). Skipping won't bring us more polymorphism when we have defaulting.
Consider
data T1 a = MkT1 T2 -- No CUSK
data T2 = MkT2 (T1 Maybe) -- Has CUSK
If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved.
With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the
program type-checks.
But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens
in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking
(T1 Maybe) will throw a type error.
Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip.
Open type families
~~~~~~~~~~~~~~~~~~
This treatment of type synonyms only applies to Haskell 98-style synonyms.
......@@ -405,9 +422,9 @@ We do the following steps:
B :-> TyConPE
MkB :-> DataConPE
2. kcTyCLGruup
2. kcTyCLGroup
- Do getInitialKinds, which will signal a promotion
error if B is used in any of the kinds needed to initialse
error if B is used in any of the kinds needed to initialise
B's kind (e.g. (a :: Type)) here
- Extend the type env with these initial kinds (monomorphic for
......@@ -512,8 +529,10 @@ kcTyClGroup decls
-- NB: the environment extension overrides the tycon
-- promotion-errors bindings
-- See Note [Type environment evolution]
; poly_kinds <- xoptM LangExt.PolyKinds
; tcExtendKindEnvWithTyCons mono_tcs $
mapM_ kcLTyClDecl no_cusk_decls
mapM_ kcLTyClDecl (if poly_kinds then no_cusk_decls else decls)
-- See Note [Skip decls with CUSKs in kcLTyClDecl]
; return mono_tcs }
......@@ -810,8 +829,8 @@ We do kind inference as follows:
Note [Unification variables need fresh Names]
Assign initial monomorophic kinds to S, T
S :: kk1 -> * -> kk2 -> *
T :: kk3 -> * -> kk4 -> *
T :: kk1 -> * -> kk2 -> *
S :: kk3 -> * -> kk4 -> *
* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and
T, with these monomophic kinds. Now kind-check the declarations,
......@@ -900,7 +919,7 @@ But when typechecking the default declarations for 'cop' and 'dop' in
tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope.
But at that point all we have is the utterly-final Class itself.
Conclusion: the classTyVars of a class must have the same Mame as
Conclusion: the classTyVars of a class must have the same Name as
that originally assigned by the user. In our example, C must have
classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite
the fact that kka and kkb got unified!
......