Skip to content
Commits on Source (7)
  • 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 `InvisArg` to `Inferred`. As a
      consequence, the iface pretty-printer correctly recognizes that
      equality coercions are inferred arguments, and as a result,
      only displays them in `-fprint-explicit-kinds` is enabled.
    * Speaking of iface pretty-printing, `Anon InvisArg` binders were
      previously being pretty-printed like `T (a :: b ~ c)`, as if they
      were required. This seemed inconsistent with other invisible
      arguments (that are printed like `T @{d}`), so I decided to switch
      this to `T @{a :: b ~ c}`.
    
    Along the way, I also cleaned up a minor inaccuracy in the users'
    guide section for constraints in kinds that was spotted in
    #12102 (comment 136220).
    
    Fixes #12102 and #15872.
    cc495d57
...@@ -144,16 +144,19 @@ lint-release-changelogs: ...@@ -144,16 +144,19 @@ lint-release-changelogs:
- ./boot - ./boot
- ./configure $CONFIGURE_ARGS - ./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 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 - mv _build/bindist/ghc*.tar.xz ghc.tar.xz
cache: cache:
key: hadrian key: hadrian
paths: paths:
- cabal-cache - cabal-cache
artifacts: artifacts:
when: always reports:
junit: junit.xml
expire_in: 2 week
paths: paths:
- ghc.tar.xz - ghc.tar.xz
- junit.xml
validate-x86_64-linux-deb8-hadrian: validate-x86_64-linux-deb8-hadrian:
extends: .validate-hadrian extends: .validate-hadrian
......
...@@ -752,10 +752,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do ...@@ -752,10 +752,6 @@ ds_expr _ (HsTickPragma _ _ _ _ expr) = do
-- HsSyn constructs that just shouldn't be here: -- HsSyn constructs that just shouldn't be here:
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" 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 _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
ds_expr _ (XExpr {}) = panic "dsExpr: XExpr" ds_expr _ (XExpr {}) = panic "dsExpr: XExpr"
......
...@@ -870,18 +870,6 @@ instance ( a ~ GhcPass p ...@@ -870,18 +870,6 @@ instance ( a ~ GhcPass p
HsSpliceE _ x -> HsSpliceE _ x ->
[ toHie $ L mspan 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 _ -> [] XExpr _ -> []
instance ( a ~ GhcPass p instance ( a ~ GhcPass p
......
...@@ -624,32 +624,6 @@ data HsExpr p ...@@ -624,32 +624,6 @@ data HsExpr p
-- See note [Pragma source text] in BasicTypes -- See note [Pragma source text] in BasicTypes
(LHsExpr p) (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 -- Finally, HsWrap appears only in typechecker output
-- The contained Expr is *NOT* itself an HsWrap. -- The contained Expr is *NOT* itself an HsWrap.
...@@ -761,10 +735,6 @@ type instance XStatic GhcTc = NameSet ...@@ -761,10 +735,6 @@ type instance XStatic GhcTc = NameSet
type instance XTick (GhcPass _) = NoExt type instance XTick (GhcPass _) = NoExt
type instance XBinTick (GhcPass _) = NoExt type instance XBinTick (GhcPass _) = NoExt
type instance XTickPragma (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 XWrap (GhcPass _) = NoExt
type instance XXExpr (GhcPass _) = NoExt type instance XXExpr (GhcPass _) = NoExt
...@@ -924,21 +894,12 @@ ppr_expr e@(HsApp {}) = ppr_apps e [] ...@@ -924,21 +894,12 @@ ppr_expr e@(HsApp {}) = ppr_apps e []
ppr_expr e@(HsAppType {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e []
ppr_expr (OpApp _ e1 op e2) 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 = pp_infixly pp_op
| otherwise | otherwise
= pp_prefixly = pp_prefixly
where 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_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens
pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear
...@@ -951,36 +912,30 @@ ppr_expr (OpApp _ e1 op e2) ...@@ -951,36 +912,30 @@ ppr_expr (OpApp _ e1 op e2)
ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e
ppr_expr (SectionL _ expr op) ppr_expr (SectionL _ expr op)
= case unLoc op of | Just pp_op <- ppr_infix_expr (unLoc op)
HsVar _ (L _ v) -> pp_infixly v = pp_infixly pp_op
HsConLikeOut _ c -> pp_infixly (conLikeName c) | otherwise
HsUnboundVar _ h@TrueExprHole{} = pp_prefixly
-> pp_infixly (unboundVarOcc h)
_ -> pp_prefixly
where where
pp_expr = pprDebugParendExpr opPrec expr pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, text "x_ )"]) 4 (hsep [pp_expr, text "x_ )"])
pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc pp_infixly v = (sep [pp_expr, v])
pp_infixly v = (sep [pp_expr, pprInfixOcc v])
ppr_expr (SectionR _ op expr) ppr_expr (SectionR _ op expr)
= case unLoc op of | Just pp_op <- ppr_infix_expr (unLoc op)
HsVar _ (L _ v) -> pp_infixly v = pp_infixly pp_op
HsConLikeOut _ c -> pp_infixly (conLikeName c) | otherwise
HsUnboundVar _ h@TrueExprHole{} = pp_prefixly
-> pp_infixly (unboundVarOcc h)
_ -> pp_prefixly
where where
pp_expr = pprDebugParendExpr opPrec expr pp_expr = pprDebugParendExpr opPrec expr
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
4 (pp_expr <> rparen) 4 (pp_expr <> rparen)
pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc pp_infixly v = sep [v, pp_expr]
pp_infixly v = sep [pprInfixOcc v, pp_expr]
ppr_expr (ExplicitTuple _ exprs boxity) ppr_expr (ExplicitTuple _ exprs boxity)
= tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
...@@ -1057,11 +1012,6 @@ ppr_expr (ExprWithTySig _ expr sig) ...@@ -1057,11 +1012,6 @@ ppr_expr (ExprWithTySig _ expr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info) 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) ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)
= sep [ pprWithSourceText st (text "{-# SCC") = sep [ pprWithSourceText st (text "{-# SCC")
-- no doublequotes if stl empty, for the case where the SCC was written -- no doublequotes if stl empty, for the case where the SCC was written
...@@ -1110,6 +1060,14 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) ...@@ -1110,6 +1060,14 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
ppr_expr (HsRecFld _ f) = ppr f ppr_expr (HsRecFld _ f) = ppr f
ppr_expr (XExpr x) = ppr x 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)) ppr_apps :: (OutputableBndrId (GhcPass p))
=> HsExpr (GhcPass p) => HsExpr (GhcPass p)
-> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
...@@ -1196,10 +1154,6 @@ hsExprNeedsParens p = go ...@@ -1196,10 +1154,6 @@ hsExprNeedsParens p = go
go (RecordUpd{}) = False go (RecordUpd{}) = False
go (ExprWithTySig{}) = p >= sigPrec go (ExprWithTySig{}) = p >= sigPrec
go (ArithSeq{}) = False go (ArithSeq{}) = False
go (EWildPat{}) = False
go (ELazyPat{}) = False
go (EAsPat{}) = False
go (EViewPat{}) = True
go (HsSCC{}) = p >= appPrec go (HsSCC{}) = p >= appPrec
go (HsWrap _ _ e) = go e go (HsWrap _ _ e) = go e
go (HsSpliceE{}) = False go (HsSpliceE{}) = False
......
...@@ -539,10 +539,6 @@ type family XStatic x ...@@ -539,10 +539,6 @@ type family XStatic x
type family XTick x type family XTick x
type family XBinTick x type family XBinTick x
type family XTickPragma 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 XWrap x
type family XXExpr x type family XXExpr x
...@@ -587,10 +583,6 @@ type ForallXExpr (c :: * -> Constraint) (x :: *) = ...@@ -587,10 +583,6 @@ type ForallXExpr (c :: * -> Constraint) (x :: *) =
, c (XTick x) , c (XTick x)
, c (XBinTick x) , c (XBinTick x)
, c (XTickPragma x) , c (XTickPragma x)
, c (XEWildPat x)
, c (XEAsPat x)
, c (XEViewPat x)
, c (XELazyPat x)
, c (XWrap x) , c (XWrap x)
, c (XXExpr x) , c (XXExpr x)
) )
......
...@@ -92,11 +92,12 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do ...@@ -92,11 +92,12 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
(defaultDumpStyle dflags) (defaultDumpStyle dflags)
sd sd
QuietBinIFaceReading -> \_ -> return () 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 ": " <> printer (text what <> text ": " <>
vcat [text "Wanted " <> ppr wanted <> text ",", vcat [text "Wanted " <> ppr' wanted <> text ",",
text "got " <> ppr got]) text "got " <> ppr' got])
errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch what wanted got = errorOnMismatch what wanted got =
...@@ -111,7 +112,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do ...@@ -111,7 +112,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
-- (This magic number does not change when we change -- (This magic number does not change when we change
-- GHC interface file format) -- GHC interface file format)
magic <- get bh magic <- get bh
wantedGot "Magic" (binaryInterfaceMagic dflags) magic wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr
errorOnMismatch "magic number mismatch: old/corrupt interface file?" errorOnMismatch "magic number mismatch: old/corrupt interface file?"
(binaryInterfaceMagic dflags) magic (binaryInterfaceMagic dflags) magic
...@@ -129,12 +130,12 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do ...@@ -129,12 +130,12 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
-- Check the interface file version and ways. -- Check the interface file version and ways.
check_ver <- get bh check_ver <- get bh
let our_ver = show hiVersion 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 errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_way <- get bh check_way <- get bh
let way_descr = getWayDescr dflags let way_descr = getWayDescr dflags
wantedGot "Way" way_descr check_way wantedGot "Way" way_descr check_way ppr
when (checkHiWay == CheckHiWay) $ when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way errorOnMismatch "mismatched interface file ways" way_descr check_way
getWithUserData ncu bh getWithUserData ncu bh
......
...@@ -719,8 +719,9 @@ pprIfaceTyConBinders = sep . map go ...@@ -719,8 +719,9 @@ pprIfaceTyConBinders = sep . map go
-- See Note [Pretty-printing invisible arguments] -- See Note [Pretty-printing invisible arguments]
case vis of case vis of
AnonTCB VisArg -> ppr_bndr True AnonTCB VisArg -> ppr_bndr True
AnonTCB InvisArg -> ppr_bndr True -- Rare; just promoted GADT data constructors AnonTCB InvisArg -> char '@' <> braces (ppr_bndr False)
-- Should we print them differently? -- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.)
-- Should we print these differently?
NamedTCB Required -> ppr_bndr True NamedTCB Required -> ppr_bndr True
NamedTCB Specified -> char '@' <> ppr_bndr True NamedTCB Specified -> char '@' <> ppr_bndr True
NamedTCB Inferred -> char '@' <> braces (ppr_bndr False) NamedTCB Inferred -> char '@' <> braces (ppr_bndr False)
......
...@@ -309,8 +309,14 @@ toIfaceAppArgsX fr kind ty_args ...@@ -309,8 +309,14 @@ toIfaceAppArgsX fr kind ty_args
t' = toIfaceTypeX fr t t' = toIfaceTypeX fr t
ts' = go (extendTCvSubst env tv t) res ts ts' = go (extendTCvSubst env tv t) res ts
go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps go env (FunTy { ft_af = af, ft_res = res }) (t:ts)
= IA_Arg (toIfaceTypeX fr t) Required (go env res 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) go env ty ts@(t1:ts1)
| not (isEmptyTCvSubst env) | not (isEmptyTCvSubst env)
......
...@@ -58,7 +58,6 @@ module Lexer ( ...@@ -58,7 +58,6 @@ module Lexer (
activeContext, nextIsEOF, activeContext, nextIsEOF,
getLexState, popLexState, pushLexState, getLexState, popLexState, pushLexState,
ExtBits(..), ExtBits(..),
addWarning,
lexTokenStream, lexTokenStream,
AddAnn,mkParensApiAnn, AddAnn,mkParensApiAnn,
commentToAnnotation commentToAnnotation
...@@ -2493,6 +2492,9 @@ class Monad m => MonadP m where ...@@ -2493,6 +2492,9 @@ class Monad m => MonadP m where
-- more than one parse error per file. -- more than one parse error per file.
-- --
addError :: SrcSpan -> SDoc -> m () 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 -- | 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. -- the parser will not produce any result, ending in a 'PFailed' state.
addFatalError :: SrcSpan -> SDoc -> m a addFatalError :: SrcSpan -> SDoc -> m a
...@@ -2515,6 +2517,16 @@ instance MonadP P where ...@@ -2515,6 +2517,16 @@ instance MonadP P where
es' = es `snocBag` errormsg es' = es `snocBag` errormsg
in (ws, es') in (ws, es')
in POk s{messages=m'} () 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 = addFatalError span msg =
addError span msg >> P PFailed addError span msg >> P PFailed
getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s)
...@@ -2524,20 +2536,6 @@ instance MonadP P where ...@@ -2524,20 +2536,6 @@ instance MonadP P where
addAnnotationOnly l a v addAnnotationOnly l a v
allocateComments l 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 :: RealSrcSpan -> P ()
addTabWarning srcspan addTabWarning srcspan
= P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
......
This diff is collapsed.
...@@ -13,8 +13,6 @@ ...@@ -13,8 +13,6 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
module RdrHsSyn ( module RdrHsSyn (
...@@ -51,11 +49,11 @@ module RdrHsSyn ( ...@@ -51,11 +49,11 @@ module RdrHsSyn (
-- Bunch of functions in the parser monad for -- Bunch of functions in the parser monad for
-- checking and constructing values -- checking and constructing values
checkExpBlockArguments,
checkPrecP, -- Int -> P Int checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext checkContext, -- HsType -> P HsContext
checkPattern, -- HsExp -> P HsPat checkPattern, -- HsExp -> P HsPat
checkPattern_msg, checkPattern_msg,
bang_RDR,
isBangRdr, isBangRdr,
isTildeRdr, isTildeRdr,
checkMonadComp, -- P (HsStmtContext RdrName) checkMonadComp, -- P (HsStmtContext RdrName)
...@@ -85,16 +83,19 @@ module RdrHsSyn ( ...@@ -85,16 +83,19 @@ module RdrHsSyn (
warnStarIsType, warnStarIsType,
failOpFewArgs, failOpFewArgs,
SumOrTuple (..), mkSumOrTuple, SumOrTuple (..),
-- Expression/command ambiguity resolution -- Expression/command/pattern ambiguity resolution
PV, PV,
runPV, runPV,
ExpCmdP(ExpCmdP, runExpCmdPV), ECP(ECP, runECP_PV),
runExpCmdP, runECP_P,
ExpCmdI(..), DisambInfixOp(..),
ecFromExp, DisambECP(..),
ecFromCmd, ecpFromExp,
ecpFromCmd,
PatBuilder,
patBuilderBang,
) where ) where
...@@ -911,7 +912,7 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) ...@@ -911,7 +912,7 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
++ occNameString occ)) ++ occNameString occ))
check _ = panic "checkRuleTyVarBndrNames" 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) checkRecordSyntax lr@(dL->L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit = do allowed <- getBit TraditionalRecordSyntaxBit
unless allowed $ addError loc $ unless allowed $ addError loc $
...@@ -1056,117 +1057,80 @@ checkNoDocs msg ty = go ty ...@@ -1056,117 +1057,80 @@ checkNoDocs msg ty = go ty
-- We parse patterns as expressions and check for valid patterns below, -- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time. -- 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 = runPV . checkLPat
checkPattern_msg :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)
checkPattern_msg msg = runPV_msg msg . checkLPat 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 [] checkLPat e@(dL->L l _) = checkPat l e []
checkPat :: SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
-> PV (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))) | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args)))
| not (null args) && patIsRec c = | not (null args) && patIsRec c =
localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ 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 checkPat loc e args -- OK to let this happen even if bang-patterns
-- are not enabled, because there is no valid -- are not enabled, because there is no valid
-- non-bang-pattern parse of (C ! e) -- non-bang-pattern parse of (C ! e)
| Just (e', args') <- splitBang e | Just (e', args') <- splitBang e
= do { args'' <- mapM checkLPat args' = do { args'' <- mapM checkLPat args'
; checkPat loc e' (args'' ++ 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 = do p <- checkLPat e
checkPat loc f (p : args) checkPat loc f (p : args)
checkPat loc (dL->L _ e) [] checkPat loc (dL->L _ e) []
= do p <- checkAPat loc e = do p <- checkAPat loc e
return (cL loc p) return (cL loc p)
checkPat loc e _ 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 checkAPat loc e0 = do
nPlusKPatterns <- getBit NPlusKPatternsBit nPlusKPatterns <- getBit NPlusKPatternsBit
case e0 of case e0 of
EWildPat _ -> return (WildPat noExt) PatBuilderPat p -> return p
HsVar _ x -> return (VarPat noExt x) PatBuilderVar 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)
-- Overloaded numeric patterns (e.g. f 0 x = x) -- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve -- Negation is recorded separately, so that the literal is zero or +ve
-- NB. Negative *primitive* literals are already handled by the lexer -- NB. Negative *primitive* literals are already handled by the lexer
HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing)
NegApp _ (dL->L l (HsOverLit _ pos_lit)) _
-> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr))
SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x) PatBuilderBang lb e -- (! x)
| bang == bang_RDR
-> do { hintBangPat loc e0 -> do { hintBangPat loc e0
; e' <- checkLPat e ; e' <- checkLPat e
; addAnnotation loc AnnBang lb ; addAnnotation loc AnnBang lb
; return (BangPat noExt e') } ; 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 -- n+k patterns
OpApp _ (dL->L nloc (HsVar _ (dL->L _ n))) PatBuilderOpApp
(dL->L _ (HsVar _ (dL->L _ plus))) (dL->L nloc (PatBuilderVar (dL->L _ n)))
(dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) (dL->L _ plus)
(dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
| nPlusKPatterns && (plus == plus_RDR) | nPlusKPatterns && (plus == plus_RDR)
-> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) -> 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 l <- checkLPat l
r <- checkLPat r r <- checkLPat r
return (ConPatIn (cL cl c) (InfixCon l r)) return (ConPatIn (cL cl c) (InfixCon l r))
OpApp {} -> patFail loc e0 PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExt))
_ -> patFail loc (ppr 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
placeHolderPunRhs :: LHsExpr GhcPs placeHolderPunRhs :: DisambECP b => PV (Located b)
-- The RHS of a punned record field will be filled in by the renamer -- 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 -- It's better not to make it an error, in case we want to print it when
-- debugging -- 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 plus_RDR = mkUnqual varName (fsLit "+") -- Hack
bang_RDR = mkUnqual varName (fsLit "!") -- Hack
pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side")
isBangRdr, isTildeRdr :: RdrName -> Bool isBangRdr, isTildeRdr :: RdrName -> Bool
...@@ -1174,31 +1138,30 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!" ...@@ -1174,31 +1138,30 @@ isBangRdr (Unqual occ) = occNameFS occ == fsLit "!"
isBangRdr _ = False isBangRdr _ = False
isTildeRdr = (==eqTyCon_RDR) isTildeRdr = (==eqTyCon_RDR)
checkPatField :: LHsRecField GhcPs (LHsExpr GhcPs) checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))
-> PV (LHsRecField GhcPs (LPat GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs))
checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld) checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld)
return (cL l (fld { hsRecFieldArg = p })) 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 patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
patIsRec :: RdrName -> Bool patIsRec :: RdrName -> Bool
patIsRec e = e == mkUnqual varName (fsLit "rec") patIsRec e = e == mkUnqual varName (fsLit "rec")
--------------------------------------------------------------------------- ---------------------------------------------------------------------------
-- Check Equation Syntax -- Check Equation Syntax
checkValDef :: SrcStrictness checkValDef :: SrcStrictness
-> LHsExpr GhcPs -> Located (PatBuilder GhcPs)
-> Maybe (LHsType GhcPs) -> Maybe (LHsType GhcPs)
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs) -> P ([AddAnn],HsBind GhcPs)
checkValDef _strictness lhs (Just sig) grhss checkValDef _strictness lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding -- x :: ty = rhs parses as a *pattern* binding
= checkPatBind (cL (combineLocs lhs sig) = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat
(ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss checkPatBind lhs' grhss
checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) checkValDef strictness lhs Nothing g@(dL->L l (_,grhss))
= do { mb_fun <- isFunLhs lhs = do { mb_fun <- isFunLhs lhs
...@@ -1206,14 +1169,16 @@ checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) ...@@ -1206,14 +1169,16 @@ checkValDef strictness lhs Nothing g@(dL->L l (_,grhss))
Just (fun, is_infix, pats, ann) -> Just (fun, is_infix, pats, ann) ->
checkFunBind strictness ann (getLoc lhs) checkFunBind strictness ann (getLoc lhs)
fun is_infix pats (cL l grhss) fun is_infix pats (cL l grhss)
Nothing -> checkPatBind lhs g } Nothing -> do
lhs' <- checkPattern lhs
checkPatBind lhs' g }
checkFunBind :: SrcStrictness checkFunBind :: SrcStrictness
-> [AddAnn] -> [AddAnn]
-> SrcSpan -> SrcSpan
-> Located RdrName -> Located RdrName
-> LexicalFixity -> LexicalFixity
-> [LHsExpr GhcPs] -> [Located (PatBuilder GhcPs)]
-> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind 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 (dL->L rhs_span grhss)
...@@ -1242,13 +1207,11 @@ makeFunBind fn ms ...@@ -1242,13 +1207,11 @@ makeFunBind fn ms
fun_co_fn = idHsWrapper, fun_co_fn = idHsWrapper,
fun_tick = [] } fun_tick = [] }
checkPatBind :: LHsExpr GhcPs checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs) -> P ([AddAnn],HsBind GhcPs)
checkPatBind lhs (dL->L _ (_,grhss)) 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 :: LHsExpr GhcPs -> P (Located RdrName)
checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v)))
...@@ -1282,10 +1245,10 @@ checkValSigLhs lhs@(dL->L l _) ...@@ -1282,10 +1245,10 @@ checkValSigLhs lhs@(dL->L l _)
default_RDR = mkUnqual varName (fsLit "default") default_RDR = mkUnqual varName (fsLit "default")
pattern_RDR = mkUnqual varName (fsLit "pattern") pattern_RDR = mkUnqual varName (fsLit "pattern")
checkDoAndIfThenElse' checkDoAndIfThenElse
:: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c)
=> a -> Bool -> b -> Bool -> c -> PV () => a -> Bool -> b -> Bool -> c -> PV ()
checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr
| semiThen || semiElse | semiThen || semiElse
= do doAndIfThenElse <- getBit DoAndIfThenElseBit = do doAndIfThenElse <- getBit DoAndIfThenElseBit
unless doAndIfThenElse $ do unless doAndIfThenElse $ do
...@@ -1303,20 +1266,21 @@ checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr ...@@ -1303,20 +1266,21 @@ checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr
-- The parser left-associates, so there should -- The parser left-associates, so there should
-- not be any OpApps inside the e's -- 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]) -- 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)) splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg))
| op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns) | isBangRdr (unLoc op)
= Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns)
where where
l' = combineLocs bang arg1 l' = combineLocs op arg1
(arg1,argns) = split_bang r_arg [] (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) split_bang e es = (e,es)
splitBang _ = Nothing splitBang _ = Nothing
-- See Note [isFunLhs vs mergeDataCon] -- See Note [isFunLhs vs mergeDataCon]
isFunLhs :: LHsExpr GhcPs isFunLhs :: Located (PatBuilder GhcPs)
-> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn])) -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))
-- A variable binding is parsed as a FunBind. -- A variable binding is parsed as a FunBind.
-- Just (fun, is_infix, arg_pats) if e is a function LHS -- Just (fun, is_infix, arg_pats) if e is a function LHS
-- --
...@@ -1331,17 +1295,15 @@ isFunLhs :: LHsExpr GhcPs ...@@ -1331,17 +1295,15 @@ isFunLhs :: LHsExpr GhcPs
isFunLhs e = go e [] [] isFunLhs e = go e [] []
where 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)) | 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 _ (PatBuilderApp 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 l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)
-- Things of the form `!x` are also FunBinds -- Things of the form `!x` are also FunBinds
-- See Note [FunBind vs PatBind] -- See Note [FunBind vs PatBind]
go (dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang))) go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann
(dL->L l (HsVar _ (L _ var))))) [] ann | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann))
| bang == bang_RDR
, not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann))
-- For infix function defns, there should be only one infix *function* -- For infix function defns, there should be only one infix *function*
-- (though there may be infix *datacons* involved too). So we don't -- (though there may be infix *datacons* involved too). So we don't
...@@ -1356,7 +1318,7 @@ isFunLhs e = go e [] [] ...@@ -1356,7 +1318,7 @@ isFunLhs e = go e [] []
-- ToDo: what about this? -- ToDo: what about this?
-- x + 1 `op` y = ... -- 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 | Just (e',es') <- splitBang e
= do { bang_on <- getBit BangPatBit = do { bang_on <- getBit BangPatBit
; if bang_on then go e' (es' ++ es) ann ; if bang_on then go e' (es' ++ es) ann
...@@ -1370,8 +1332,8 @@ isFunLhs e = go e [] [] ...@@ -1370,8 +1332,8 @@ isFunLhs e = go e [] []
Just (op', Infix, j : k : es', ann') Just (op', Infix, j : k : es', ann')
-> return (Just (op', Infix, j : op_app : es', ann')) -> return (Just (op', Infix, j : op_app : es', ann'))
where where
op_app = cL loc (OpApp noExt k op_app = cL loc (PatBuilderOpApp k
(cL loc' (HsVar noExt (cL loc' op))) r) (cL loc' op) r)
_ -> return Nothing } _ -> return Nothing }
go _ _ _ = return Nothing go _ _ _ = return Nothing
...@@ -1856,7 +1818,7 @@ mergeDataCon all_xs = ...@@ -1856,7 +1818,7 @@ mergeDataCon all_xs =
-- If the flag MonadComprehensions is set, return a 'MonadComp' context, -- If the flag MonadComprehensions is set, return a 'MonadComp' context,
-- otherwise use the usual 'ListComp' context -- otherwise use the usual 'ListComp' context
checkMonadComp :: P (HsStmtContext Name) checkMonadComp :: PV (HsStmtContext Name)
checkMonadComp = do checkMonadComp = do
monadComprehensions <- getBit MonadComprehensionsBit monadComprehensions <- getBit MonadComprehensionsBit
return $ if monadComprehensions return $ if monadComprehensions
...@@ -1864,96 +1826,373 @@ checkMonadComp = do ...@@ -1864,96 +1826,373 @@ checkMonadComp = do
else ListComp else ListComp
-- ------------------------------------------------------------------------- -- -------------------------------------------------------------------------
-- Expression/command ambiguity (arrow syntax). -- Expression/command/pattern ambiguity.
-- See Note [Ambiguous syntactic categories] -- 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 [Parser-Validator]
-- See Note [Ambiguous syntactic categories] -- See Note [Ambiguous syntactic categories]
newtype ExpCmdP = newtype ECP =
ExpCmdP { runExpCmdPV :: forall b. ExpCmdI b => PV (Located (b GhcPs)) } ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }
runExpCmdP :: ExpCmdI b => ExpCmdP -> P (Located (b GhcPs)) runECP_P :: DisambECP b => ECP -> P (Located b)
runExpCmdP p = runPV (runExpCmdPV p) runECP_P p = runPV (runECP_PV p)
ecFromExp :: LHsExpr GhcPs -> ExpCmdP ecpFromExp :: LHsExpr GhcPs -> ECP
ecFromExp a = ExpCmdP (ecFromExp' a) ecpFromExp a = ECP (ecpFromExp' a)
ecFromCmd :: LHsCmd GhcPs -> ExpCmdP ecpFromCmd :: LHsCmd GhcPs -> ECP
ecFromCmd a = ExpCmdP (ecFromCmd' a) 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] -- 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. -- | 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. -- | 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) -- | Disambiguate "\... -> ..." (lambda)
ecHsLam :: MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)
-- | Disambiguate "let ... in ..." -- | 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) -- | 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 ..." -- | 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) -- | 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 ..." -- | 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) -- | 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) -- | Disambiguate "( ... )" (parentheses)
ecHsPar :: Located (b GhcPs) -> b GhcPs mkHsParPV :: SrcSpan -> Located b -> PV (Located b)
-- | Check if the argument requires -XBlockArguments. -- | Disambiguate a variable "f" or a data constructor "MkF".
checkBlockArguments :: Located (b GhcPs) -> PV () mkHsVarPV :: Located RdrName -> PV (Located b)
-- | Check if -XDoAndIfThenElse is enabled. -- | Disambiguate a monomorphic literal
checkDoAndIfThenElse :: LHsExpr GhcPs -> Bool -> Located (b GhcPs) mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)
-> Bool -> Located (b GhcPs) -> PV () -- | Disambiguate an overloaded literal
mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b)
instance ExpCmdI HsCmd where -- | Disambiguate a wildcard
ecFromCmd' = return mkHsWildCardPV :: SrcSpan -> PV (Located b)
ecFromExp' (dL-> L l e) = -- | Disambiguate "a :: t" (type annotation)
addFatalError l $ mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)
text "Parse error in command:" <+> ppr e -- | Disambiguate "[a,b,c]" (list syntax)
ecHsLam = HsCmdLam noExt mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b)
ecHsLet = HsCmdLet noExt -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)
ecOpApp c1 op c2 = mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b)
let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)
HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2] mkHsRecordPV ::
ecHsCase = HsCmdCase noExt SrcSpan ->
ecHsApp = HsCmdApp noExt SrcSpan ->
ecHsIf = mkHsCmdIf Located b ->
ecHsDo = HsCmdDo noExt ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) ->
ecHsPar = HsCmdPar noExt PV (Located b)
checkBlockArguments = checkCmdBlockArguments -- | Disambiguate "-a" (negation)
checkDoAndIfThenElse = checkDoAndIfThenElse' mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b)
-- | Disambiguate "(# a)" (right operator section)
instance ExpCmdI HsExpr where mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b)
ecFromCmd' (dL -> L l c) = do -- | 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 addError l $ vcat
[ text "Arrow command found where an expression was expected:", [ text "Arrow command found where an expression was expected:",
nest 2 (ppr c) ] nest 2 (ppr c) ]
return (cL l hsHoleExpr) return (cL l hsHoleExpr)
ecFromExp' = return ecpFromExp' = return
ecHsLam = HsLam noExt mkHsLamPV l mg = return $ cL l (HsLam noExt mg)
ecHsLet = HsLet noExt mkHsLetPV l bs c = return $ cL l (HsLet noExt bs c)
ecOpApp = OpApp noExt type InfixOp (HsExpr p) = HsExpr p
ecHsCase = HsCase noExt superInfixOp m = m
ecHsApp = HsApp noExt mkHsOpAppPV l e1 op e2 = do
ecHsIf = mkHsIf return $ cL l $ OpApp noExt e1 op e2
ecHsDo = HsDo noExt DoExpr mkHsCasePV l e mg = return $ cL l (HsCase noExt e mg)
ecHsPar = HsPar noExt type FunArg (HsExpr p) = HsExpr p
checkBlockArguments = checkExpBlockArguments superFunArg m = m
checkDoAndIfThenElse = checkDoAndIfThenElse' 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 :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) 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] {- Note [Ambiguous syntactic categories]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -2008,9 +2247,19 @@ concerns local to the parser, and does not require duplication of hsSyn types, ...@@ -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 or an extra pass over the entire AST, is to parse into an overloaded
parser-validator (a so-called tagless final encoding): parser-validator (a so-called tagless final encoding):
class ExpCmdI b where ... class DisambECP b where ...
instance ExpCmdI HsCmd where ... instance p ~ GhcPs => DisambECP (HsCmd p) where ...
instance ExpCmdI HsExp 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: Consider the 'alts' production used to parse case-of alternatives:
...@@ -2018,9 +2267,9 @@ 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) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } | ';' 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 -> : alts1 { $1 >>= \ $1 ->
return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }
| ';' alts { $2 >>= \ $2 -> | ';' alts { $2 >>= \ $2 ->
...@@ -2028,9 +2277,9 @@ We abstract over LHsExpr, and it becomes: ...@@ -2028,9 +2277,9 @@ We abstract over LHsExpr, and it becomes:
Compared to the initial definition, the added bits are: Compared to the initial definition, the added bits are:
forall b. ExpCmdI b => PV ( ... ) -- in the type signature forall b. DisambECP b => PV ( ... ) -- in the type signature
$1 >>= \ $1 -> return $ -- in one reduction rule $1 >>= \ $1 -> return $ -- in one reduction rule
$2 >>= \ $2 -> return $ -- in another reduction rule $2 >>= \ $2 -> return $ -- in another reduction rule
The overhead is constant relative to the size of the rest of the reduction The overhead is constant relative to the size of the rest of the reduction
rule, so this approach scales well to large parser productions. rule, so this approach scales well to large parser productions.
...@@ -2316,11 +2565,80 @@ thread 'tag' explicitly: ...@@ -2316,11 +2565,80 @@ thread 'tag' explicitly:
| ';' alts { $2 >>= \ $2 -> | ';' alts { $2 >>= \ $2 ->
return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $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 This encoding works well enough, but introduces an extra GADT unlike the
more cases (Exp vs Cmd vs Pat), as we would need multiple GADTs for all possible ambiguities. 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 -- Miscellaneous utilities
...@@ -2342,7 +2660,7 @@ mkRecConstrOrUpdate ...@@ -2342,7 +2660,7 @@ mkRecConstrOrUpdate
:: LHsExpr GhcPs :: LHsExpr GhcPs
-> SrcSpan -> SrcSpan
-> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)
-> P (HsExpr GhcPs) -> PV (HsExpr GhcPs)
mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd)
| isRdrDataCon c | isRdrDataCon c
...@@ -2680,6 +2998,8 @@ localPV_msg f (PV m) = PV (local f m) ...@@ -2680,6 +2998,8 @@ localPV_msg f (PV m) = PV (local f m)
instance MonadP PV where instance MonadP PV where
addError srcspan msg = addError srcspan msg =
PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg) PV $ ReaderT $ \ctxMsg -> addError srcspan (msg $$ ctxMsg)
addWarning option srcspan msg =
PV $ ReaderT $ \_ -> addWarning option srcspan msg
addFatalError srcspan msg = addFatalError srcspan msg =
PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg) PV $ ReaderT $ \ctxMsg -> addFatalError srcspan (msg $$ ctxMsg)
getBit ext = getBit ext =
...@@ -2762,35 +3082,67 @@ the error messages. ...@@ -2762,35 +3082,67 @@ the error messages.
-} -}
-- | Hint about bang patterns, assuming @BangPatterns@ is off. -- | Hint about bang patterns, assuming @BangPatterns@ is off.
hintBangPat :: SrcSpan -> HsExpr GhcPs -> PV () hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV ()
hintBangPat span e = do hintBangPat span e = do
bang_on <- getBit BangPatBit bang_on <- getBit BangPatBit
unless bang_on $ unless bang_on $
addFatalError span addFatalError span
(text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)
data SumOrTuple data SumOrTuple b
= Sum ConTag Arity (LHsExpr GhcPs) = Sum ConTag Arity (Located b)
| Tuple [LHsTupArg GhcPs] | 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 -- 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 -- Sum
mkSumOrTuple Unboxed _ (Sum alt arity e) = mkSumOrTupleExpr l Unboxed (Sum alt arity e) =
return (ExplicitSum noExt alt arity e) return $ cL l (ExplicitSum noExt alt arity e)
mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) = mkSumOrTupleExpr l Boxed a@Sum{} =
addFatalError l (hang (text "Boxed sums not supported:") 2 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 where
ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)
ppr_boxed_sum alt arity e = toTupPat (dL -> L l p) = case p of
text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) Nothing -> addFatalError l (text "Tuple section in pattern context")
<+> text ")" 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 :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy x op y = mkLHsOpTy x op y =
......
...@@ -140,6 +140,9 @@ rnExpr (HsVar _ (L l v)) ...@@ -140,6 +140,9 @@ rnExpr (HsVar _ (L l v))
rnExpr (HsIPVar x v) rnExpr (HsIPVar x v)
= return (HsIPVar x v, emptyFVs) = return (HsIPVar x v, emptyFVs)
rnExpr (HsUnboundVar x v)
= return (HsUnboundVar x v, emptyFVs)
rnExpr (HsOverLabel x _ v) rnExpr (HsOverLabel x _ v)
= do { rebindable_on <- xoptM LangExt.RebindableSyntax = do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on ; if rebindable_on
...@@ -345,24 +348,6 @@ rnExpr (ArithSeq x _ seq) ...@@ -345,24 +348,6 @@ rnExpr (ArithSeq x _ seq)
else else
return (ArithSeq x Nothing new_seq, fvs) } 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) ...@@ -415,9 +400,6 @@ rnExpr (HsProc x pat body)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-- HsWrap -- HsWrap
hsHoleExpr :: HsExpr (GhcPass id)
hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
---------------------- ----------------------
-- See Note [Parsing sections] in Parser.y -- See Note [Parsing sections] in Parser.y
rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
...@@ -2087,12 +2069,6 @@ sectionErr expr ...@@ -2087,12 +2069,6 @@ sectionErr expr
= hang (text "A section must be enclosed in parentheses") = hang (text "A section must be enclosed in parentheses")
2 (text "thus:" <+> (parens (ppr expr))) 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 :: Outputable a => SDoc -> a -> SDoc
badIpBinds what binds badIpBinds what binds
= hang (text "Implicit-parameter bindings illegal in" <+> what) = hang (text "Implicit-parameter bindings illegal in" <+> what)
......
...@@ -2368,13 +2368,13 @@ etaExpandAlgTyCon tc_bndrs kind ...@@ -2368,13 +2368,13 @@ etaExpandAlgTyCon tc_bndrs kind
= case splitPiTy_maybe kind of = case splitPiTy_maybe kind of
Nothing -> (reverse acc, substTy subst kind) Nothing -> (reverse acc, substTy subst kind)
Just (Anon _ arg, kind') Just (Anon af arg, kind')
-> go loc occs' uniqs' subst' (tcb : acc) kind' -> go loc occs' uniqs' subst' (tcb : acc) kind'
where where
arg' = substTy subst arg arg' = substTy subst arg
tv = mkTyVar (mkInternalName uniq occ loc) arg' tv = mkTyVar (mkInternalName uniq occ loc) arg'
subst' = extendTCvInScope subst tv subst' = extendTCvInScope subst tv
tcb = Bndr tv (AnonTCB VisArg) tcb = Bndr tv (AnonTCB af)
(uniq:uniqs') = uniqs (uniq:uniqs') = uniqs
(occ:occs') = occs (occ:occs') = occs
......
...@@ -3662,10 +3662,6 @@ exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" ...@@ -3662,10 +3662,6 @@ exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e
exprCtOrigin (HsTickPragma _ _ _ _ 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 (HsWrap {}) = panic "exprCtOrigin HsWrap"
exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr" exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr"
......
...@@ -288,7 +288,7 @@ we can get away with this is because we have more systematic TYPE r ...@@ -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 inference, which means that we can do unification between kinds that
aren't lifted (this historically was not true.) 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 type synonyms in topological order is that we don't transparently
support making synonyms of types with higher-rank kinds. But support making synonyms of types with higher-rank kinds. But
you can always specify a CUSK directly to make this work out. 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 ...@@ -314,6 +314,23 @@ This gets us more polymorphism than we would otherwise get, similar
(but implemented strangely differently from) the treatment of type (but implemented strangely differently from) the treatment of type
signatures in value declarations. 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 Open type families
~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~
This treatment of type synonyms only applies to Haskell 98-style synonyms. This treatment of type synonyms only applies to Haskell 98-style synonyms.
...@@ -405,9 +422,9 @@ We do the following steps: ...@@ -405,9 +422,9 @@ We do the following steps:
B :-> TyConPE B :-> TyConPE
MkB :-> DataConPE MkB :-> DataConPE
2. kcTyCLGruup 2. kcTyCLGroup
- Do getInitialKinds, which will signal a promotion - 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 B's kind (e.g. (a :: Type)) here
- Extend the type env with these initial kinds (monomorphic for - Extend the type env with these initial kinds (monomorphic for
...@@ -512,8 +529,10 @@ kcTyClGroup decls ...@@ -512,8 +529,10 @@ kcTyClGroup decls
-- NB: the environment extension overrides the tycon -- NB: the environment extension overrides the tycon
-- promotion-errors bindings -- promotion-errors bindings
-- See Note [Type environment evolution] -- See Note [Type environment evolution]
; poly_kinds <- xoptM LangExt.PolyKinds
; tcExtendKindEnvWithTyCons mono_tcs $ ; 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 } ; return mono_tcs }
...@@ -810,8 +829,8 @@ We do kind inference as follows: ...@@ -810,8 +829,8 @@ We do kind inference as follows:
Note [Unification variables need fresh Names] Note [Unification variables need fresh Names]
Assign initial monomorophic kinds to S, T Assign initial monomorophic kinds to S, T
S :: kk1 -> * -> kk2 -> * T :: kk1 -> * -> kk2 -> *
T :: kk3 -> * -> kk4 -> * S :: kk3 -> * -> kk4 -> *
* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and * Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and
T, with these monomophic kinds. Now kind-check the declarations, 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 ...@@ -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. 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. 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 that originally assigned by the user. In our example, C must have
classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite
the fact that kka and kkb got unified! the fact that kka and kkb got unified!
......
...@@ -487,14 +487,22 @@ tyConVisibleTyVars tc ...@@ -487,14 +487,22 @@ tyConVisibleTyVars tc
= [ tv | Bndr tv vis <- tyConBinders tc = [ tv | Bndr tv vis <- tyConBinders tc
, isVisibleTcbVis vis ] , isVisibleTcbVis vis ]
{- Note [AnonTCB InivsArg] {- Note [AnonTCB InvisArg]
~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~
It's pretty rare to have an (AnonTCB InvisArg) binder. The It's pretty rare to have an (AnonTCB InvisArg) binder. The
only way it can occur is in a PromotedDataCon whose only way it can occur is through equality constraints in kinds. These
kind has an equality constraint: can arise in one of two ways:
'MkT :: forall a b. (a~b) => blah
See Note [Constraints in kinds] in TyCoRep, and * In a PromotedDataCon whose kind has an equality constraint:
Note [Promoted data constructors] in this module.
'MkT :: forall a b. (a~b) => blah
See Note [Constraints in kinds] in TyCoRep, and
Note [Promoted data constructors] in this module.
* In a data type whose kind has an equality constraint, as in the
following example from #12102:
data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type
When mapping an (AnonTCB InvisArg) to an ArgFlag, in When mapping an (AnonTCB InvisArg) to an ArgFlag, in
tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot
......
...@@ -9395,7 +9395,8 @@ Here is an example of a constrained kind: :: ...@@ -9395,7 +9395,8 @@ Here is an example of a constrained kind: ::
The declarations above are accepted. However, if we add ``MkOther :: T Int``, The declarations above are accepted. However, if we add ``MkOther :: T Int``,
we get an error that the equality constraint is not satisfied; ``Int`` is we get an error that the equality constraint is not satisfied; ``Int`` is
not a type literal. Note that explicitly quantifying with ``forall a`` is not a type literal. Note that explicitly quantifying with ``forall a`` is
not necessary here. necessary in order for ``T`` to typecheck
(see :ref:`complete-kind-signatures`).
   
The kind ``Type`` The kind ``Type``
----------------- -----------------
...@@ -10351,13 +10352,13 @@ function that can *never* be called, such as this one: :: ...@@ -10351,13 +10352,13 @@ function that can *never* be called, such as this one: ::
f :: (Int ~ Bool) => a -> a f :: (Int ~ Bool) => a -> a
   
Sometimes :extension:`AllowAmbiguousTypes` does not mix well with :extension:`RankNTypes`. Sometimes :extension:`AllowAmbiguousTypes` does not mix well with :extension:`RankNTypes`.
For example: :: For example: ::
foo :: forall r. (forall i. (KnownNat i) => r) -> r foo :: forall r. (forall i. (KnownNat i) => r) -> r
foo f = f @1 foo f = f @1
   
boo :: forall j. (KnownNat j) => Int boo :: forall j. (KnownNat j) => Int
boo = .... boo = ....
h :: Int h :: Int
h = foo boo h = foo boo
   
...@@ -10367,7 +10368,7 @@ the type variables `j` and `i`. ...@@ -10367,7 +10368,7 @@ the type variables `j` and `i`.
Unlike the previous examples, it is not currently possible Unlike the previous examples, it is not currently possible
to resolve the ambiguity manually by using :extension:`TypeApplications`. to resolve the ambiguity manually by using :extension:`TypeApplications`.
   
.. note:: .. note::
*A historical note.* GHC used to impose some more restrictive and less *A historical note.* GHC used to impose some more restrictive and less
principled conditions on type signatures. For type principled conditions on type signatures. For type
......
...@@ -139,4 +139,4 @@ data Extension ...@@ -139,4 +139,4 @@ data Extension
| NumericUnderscores | NumericUnderscores
| QuantifiedConstraints | QuantifiedConstraints
| StarIsType | StarIsType
deriving (Eq, Enum, Show, Generic) deriving (Eq, Enum, Show, Generic, Bounded)
...@@ -14,5 +14,6 @@ ...@@ -14,5 +14,6 @@
test('concprog001', [extra_files(['Arithmetic.hs', 'Converter.hs', 'Mult.hs', 'Stream.hs', 'Thread.hs', 'Trit.hs', 'Utilities.hs']), test('concprog001', [extra_files(['Arithmetic.hs', 'Converter.hs', 'Mult.hs', 'Stream.hs', 'Thread.hs', 'Trit.hs', 'Utilities.hs']),
when(fast(), skip), only_ways(['threaded2']), when(fast(), skip), only_ways(['threaded2']),
fragile(16604),
run_timeout_multiplier(2)], run_timeout_multiplier(2)],
multimod_compile_and_run, ['Mult', '']) multimod_compile_and_run, ['Mult', ''])
{-# Language RankNTypes #-}
{-# Language DataKinds #-}
{-# Language PolyKinds #-}
{-# Language GADTs #-}
module T15872 where
import Data.Kind
data WHICH = OP | OPOP
data Fun :: forall (a :: WHICH). a ~ OP => Type -> Type -> Type where
MkFun :: (a -> b) -> Fun a b