1-- 2-- (c) The University of Glasgow 2002-2006 3-- 4 5-- Functions over HsSyn specialised to RdrName. 6 7{-# LANGUAGE CPP #-} 8{-# LANGUAGE FlexibleContexts #-} 9{-# LANGUAGE FlexibleInstances #-} 10{-# LANGUAGE TypeFamilies #-} 11{-# LANGUAGE MagicHash #-} 12{-# LANGUAGE ViewPatterns #-} 13{-# LANGUAGE GADTs #-} 14{-# LANGUAGE RankNTypes #-} 15{-# LANGUAGE LambdaCase #-} 16{-# LANGUAGE TypeApplications #-} 17{-# LANGUAGE GeneralizedNewtypeDeriving #-} 18 19module RdrHsSyn ( 20 mkHsOpApp, 21 mkHsIntegral, mkHsFractional, mkHsIsString, 22 mkHsDo, mkSpliceDecl, 23 mkRoleAnnotDecl, 24 mkClassDecl, 25 mkTyData, mkDataFamInst, 26 mkTySynonym, mkTyFamInstEqn, 27 mkStandaloneKindSig, 28 mkTyFamInst, 29 mkFamDecl, mkLHsSigType, 30 mkInlinePragma, 31 mkPatSynMatchGroup, 32 mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp 33 mkTyClD, mkInstD, 34 mkRdrRecordCon, mkRdrRecordUpd, 35 setRdrNameSpace, 36 filterCTuple, 37 38 cvBindGroup, 39 cvBindsAndSigs, 40 cvTopDecls, 41 placeHolderPunRhs, 42 43 -- Stuff to do with Foreign declarations 44 mkImport, 45 parseCImport, 46 mkExport, 47 mkExtName, -- RdrName -> CLabelString 48 mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName 49 mkConDeclH98, 50 51 -- Bunch of functions in the parser monad for 52 -- checking and constructing values 53 checkImportDecl, 54 checkExpBlockArguments, 55 checkPrecP, -- Int -> P Int 56 checkContext, -- HsType -> P HsContext 57 checkPattern, -- HsExp -> P HsPat 58 checkPattern_msg, 59 isBangRdr, 60 isTildeRdr, 61 checkMonadComp, -- P (HsStmtContext RdrName) 62 checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl 63 checkValSigLhs, 64 LRuleTyTmVar, RuleTyTmVar(..), 65 mkRuleBndrs, mkRuleTyVarBndrs, 66 checkRuleTyVarBndrNames, 67 checkRecordSyntax, 68 checkEmptyGADTs, 69 addFatalError, hintBangPat, 70 TyEl(..), mergeOps, mergeDataCon, 71 72 -- Help with processing exports 73 ImpExpSubSpec(..), 74 ImpExpQcSpec(..), 75 mkModuleImpExp, 76 mkTypeImpExp, 77 mkImpExpSubSpec, 78 checkImportSpec, 79 80 -- Token symbols 81 forallSym, 82 starSym, 83 84 -- Warnings and errors 85 warnStarIsType, 86 warnPrepositiveQualifiedModule, 87 failOpFewArgs, 88 failOpNotEnabledImportQualifiedPost, 89 failOpImportQualifiedTwice, 90 91 SumOrTuple (..), 92 93 -- Expression/command/pattern ambiguity resolution 94 PV, 95 runPV, 96 ECP(ECP, runECP_PV), 97 runECP_P, 98 DisambInfixOp(..), 99 DisambECP(..), 100 ecpFromExp, 101 ecpFromCmd, 102 PatBuilder, 103 patBuilderBang, 104 105 ) where 106 107import GhcPrelude 108import GHC.Hs -- Lots of it 109import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) 110import DataCon ( DataCon, dataConTyCon ) 111import ConLike ( ConLike(..) ) 112import CoAxiom ( Role, fsFromRole ) 113import RdrName 114import Name 115import BasicTypes 116import TcEvidence ( idHsWrapper ) 117import Lexer 118import Lexeme ( isLexCon ) 119import Type ( TyThing(..), funTyCon ) 120import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, 121 nilDataConName, nilDataConKey, 122 listTyConName, listTyConKey, eqTyCon_RDR, 123 tupleTyConName, cTupleTyConNameArity_maybe ) 124import ForeignCall 125import PrelNames ( allNameStrings ) 126import SrcLoc 127import Unique ( hasKey ) 128import OrdList ( OrdList, fromOL ) 129import Bag ( emptyBag, consBag ) 130import Outputable 131import FastString 132import Maybes 133import Util 134import ApiAnnotation 135import Data.List 136import DynFlags ( WarningFlag(..), DynFlags ) 137import ErrUtils ( Messages ) 138 139import Control.Monad 140import Text.ParserCombinators.ReadP as ReadP 141import Data.Char 142import qualified Data.Monoid as Monoid 143import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) 144 145#include "GhclibHsVersions.h" 146 147 148{- ********************************************************************** 149 150 Construction functions for Rdr stuff 151 152 ********************************************************************* -} 153 154-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and 155-- datacon by deriving them from the name of the class. We fill in the names 156-- for the tycon and datacon corresponding to the class, by deriving them 157-- from the name of the class itself. This saves recording the names in the 158-- interface file (which would be equally good). 159 160-- Similarly for mkConDecl, mkClassOpSig and default-method names. 161 162-- *** See Note [The Naming story] in GHC.Hs.Decls **** 163 164mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) 165mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d) 166 167mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) 168mkInstD (dL->L loc d) = cL loc (InstD noExtField d) 169 170mkClassDecl :: SrcSpan 171 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) 172 -> Located (a,[LHsFunDep GhcPs]) 173 -> OrdList (LHsDecl GhcPs) 174 -> P (LTyClDecl GhcPs) 175 176mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls 177 = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls 178 ; let cxt = fromMaybe (noLoc []) mcxt 179 ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr 180 ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan 181 ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams 182 ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan 183 ; return (cL loc (ClassDecl { tcdCExt = noExtField, tcdCtxt = cxt 184 , tcdLName = cls, tcdTyVars = tyvars 185 , tcdFixity = fixity 186 , tcdFDs = snd (unLoc fds) 187 , tcdSigs = mkClassOpSigs sigs 188 , tcdMeths = binds 189 , tcdATs = ats, tcdATDefs = at_defs 190 , tcdDocs = docs })) } 191 192mkTyData :: SrcSpan 193 -> NewOrData 194 -> Maybe (Located CType) 195 -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) 196 -> Maybe (LHsKind GhcPs) 197 -> [LConDecl GhcPs] 198 -> HsDeriving GhcPs 199 -> P (LTyClDecl GhcPs) 200mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) 201 ksig data_cons maybe_deriv 202 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr 203 ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan 204 ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams 205 ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan 206 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv 207 ; return (cL loc (DataDecl { tcdDExt = noExtField, 208 tcdLName = tc, tcdTyVars = tyvars, 209 tcdFixity = fixity, 210 tcdDataDefn = defn })) } 211 212mkDataDefn :: NewOrData 213 -> Maybe (Located CType) 214 -> Maybe (LHsContext GhcPs) 215 -> Maybe (LHsKind GhcPs) 216 -> [LConDecl GhcPs] 217 -> HsDeriving GhcPs 218 -> P (HsDataDefn GhcPs) 219mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv 220 = do { checkDatatypeContext mcxt 221 ; let cxt = fromMaybe (noLoc []) mcxt 222 ; return (HsDataDefn { dd_ext = noExtField 223 , dd_ND = new_or_data, dd_cType = cType 224 , dd_ctxt = cxt 225 , dd_cons = data_cons 226 , dd_kindSig = ksig 227 , dd_derivs = maybe_deriv }) } 228 229 230mkTySynonym :: SrcSpan 231 -> LHsType GhcPs -- LHS 232 -> LHsType GhcPs -- RHS 233 -> P (LTyClDecl GhcPs) 234mkTySynonym loc lhs rhs 235 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs 236 ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan 237 ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams 238 ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan 239 ; return (cL loc (SynDecl { tcdSExt = noExtField 240 , tcdLName = tc, tcdTyVars = tyvars 241 , tcdFixity = fixity 242 , tcdRhs = rhs })) } 243 244mkStandaloneKindSig 245 :: SrcSpan 246 -> Located [Located RdrName] -- LHS 247 -> LHsKind GhcPs -- RHS 248 -> P (LStandaloneKindSig GhcPs) 249mkStandaloneKindSig loc lhs rhs = 250 do { vs <- mapM check_lhs_name (unLoc lhs) 251 ; v <- check_singular_lhs (reverse vs) 252 ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } 253 where 254 check_lhs_name v@(unLoc->name) = 255 if isUnqual name && isTcOcc (rdrNameOcc name) 256 then return v 257 else addFatalError (getLoc v) $ 258 hang (text "Expected an unqualified type constructor:") 2 (ppr v) 259 check_singular_lhs vs = 260 case vs of 261 [] -> panic "mkStandaloneKindSig: empty left-hand side" 262 [v] -> return v 263 _ -> addFatalError (getLoc lhs) $ 264 vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") 265 2 (pprWithCommas ppr vs) 266 , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] 267 268mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs] 269 -> LHsType GhcPs 270 -> LHsType GhcPs 271 -> P (TyFamInstEqn GhcPs,[AddAnn]) 272mkTyFamInstEqn bndrs lhs rhs 273 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs 274 ; return (mkHsImplicitBndrs 275 (FamEqn { feqn_ext = noExtField 276 , feqn_tycon = tc 277 , feqn_bndrs = bndrs 278 , feqn_pats = tparams 279 , feqn_fixity = fixity 280 , feqn_rhs = rhs }), 281 ann) } 282 283mkDataFamInst :: SrcSpan 284 -> NewOrData 285 -> Maybe (Located CType) 286 -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs] 287 , LHsType GhcPs) 288 -> Maybe (LHsKind GhcPs) 289 -> [LConDecl GhcPs] 290 -> HsDeriving GhcPs 291 -> P (LInstDecl GhcPs) 292mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) 293 ksig data_cons maybe_deriv 294 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr 295 ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan 296 ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv 297 ; return (cL loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs 298 (FamEqn { feqn_ext = noExtField 299 , feqn_tycon = tc 300 , feqn_bndrs = bndrs 301 , feqn_pats = tparams 302 , feqn_fixity = fixity 303 , feqn_rhs = defn }))))) } 304 305mkTyFamInst :: SrcSpan 306 -> TyFamInstEqn GhcPs 307 -> P (LInstDecl GhcPs) 308mkTyFamInst loc eqn 309 = return (cL loc (TyFamInstD noExtField (TyFamInstDecl eqn))) 310 311mkFamDecl :: SrcSpan 312 -> FamilyInfo GhcPs 313 -> LHsType GhcPs -- LHS 314 -> Located (FamilyResultSig GhcPs) -- Optional result signature 315 -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation 316 -> P (LTyClDecl GhcPs) 317mkFamDecl loc info lhs ksig injAnn 318 = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs 319 ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan 320 ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams 321 ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan 322 ; return (cL loc (FamDecl noExtField (FamilyDecl 323 { fdExt = noExtField 324 , fdInfo = info, fdLName = tc 325 , fdTyVars = tyvars 326 , fdFixity = fixity 327 , fdResultSig = ksig 328 , fdInjectivityAnn = injAnn }))) } 329 where 330 equals_or_where = case info of 331 DataFamily -> empty 332 OpenTypeFamily -> empty 333 ClosedTypeFamily {} -> whereDots 334 335mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs 336-- If the user wrote 337-- [pads| ... ] then return a QuasiQuoteD 338-- $(e) then return a SpliceD 339-- but if she wrote, say, 340-- f x then behave as if she'd written $(f x) 341-- ie a SpliceD 342-- 343-- Typed splices are not allowed at the top level, thus we do not represent them 344-- as spliced declaration. See #10945 345mkSpliceDecl lexpr@(dL->L loc expr) 346 | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr 347 = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) 348 349 | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr 350 = SpliceD noExtField (SpliceDecl noExtField (cL loc splice) ExplicitSplice) 351 352 | otherwise 353 = SpliceD noExtField (SpliceDecl noExtField (cL loc (mkUntypedSplice NoParens lexpr)) 354 ImplicitSplice) 355 356mkRoleAnnotDecl :: SrcSpan 357 -> Located RdrName -- type being annotated 358 -> [Located (Maybe FastString)] -- roles 359 -> P (LRoleAnnotDecl GhcPs) 360mkRoleAnnotDecl loc tycon roles 361 = do { roles' <- mapM parse_role roles 362 ; return $ cL loc $ RoleAnnotDecl noExtField tycon roles' } 363 where 364 role_data_type = dataTypeOf (undefined :: Role) 365 all_roles = map fromConstr $ dataTypeConstrs role_data_type 366 possible_roles = [(fsFromRole role, role) | role <- all_roles] 367 368 parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing 369 parse_role (dL->L loc_role (Just role)) 370 = case lookup role possible_roles of 371 Just found_role -> return $ cL loc_role $ Just found_role 372 Nothing -> 373 let nearby = fuzzyLookup (unpackFS role) 374 (mapFst unpackFS possible_roles) 375 in 376 addFatalError loc_role 377 (text "Illegal role name" <+> quotes (ppr role) $$ 378 suggestions nearby) 379 parse_role _ = panic "parse_role: Impossible Match" 380 -- due to #15884 381 382 suggestions [] = empty 383 suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) 384 -- will this last case ever happen?? 385 suggestions list = hang (text "Perhaps you meant one of these:") 386 2 (pprWithCommas (quotes . ppr) list) 387 388{- ********************************************************************** 389 390 #cvBinds-etc# Converting to @HsBinds@, etc. 391 392 ********************************************************************* -} 393 394-- | Function definitions are restructured here. Each is assumed to be recursive 395-- initially, and non recursive definitions are discovered by the dependency 396-- analyser. 397 398 399-- | Groups together bindings for a single function 400cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] 401cvTopDecls decls = go (fromOL decls) 402 where 403 go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] 404 go [] = [] 405 go ((dL->L l (ValD x b)) : ds) 406 = cL l' (ValD x b') : go ds' 407 where (dL->L l' b', ds') = getMonoBind (cL l b) ds 408 go (d : ds) = d : go ds 409 410-- Declaration list may only contain value bindings and signatures. 411cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) 412cvBindGroup binding 413 = do { (mbs, sigs, fam_ds, tfam_insts 414 , dfam_insts, _) <- cvBindsAndSigs binding 415 ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) 416 return $ ValBinds noExtField mbs sigs } 417 418cvBindsAndSigs :: OrdList (LHsDecl GhcPs) 419 -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] 420 , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) 421-- Input decls contain just value bindings and signatures 422-- and in case of class or instance declarations also 423-- associated type declarations. They might also contain Haddock comments. 424cvBindsAndSigs fb = go (fromOL fb) 425 where 426 go [] = return (emptyBag, [], [], [], [], []) 427 go ((dL->L l (ValD _ b)) : ds) 428 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' 429 ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } 430 where 431 (b', ds') = getMonoBind (cL l b) ds 432 go ((dL->L l decl) : ds) 433 = do { (bs, ss, ts, tfis, dfis, docs) <- go ds 434 ; case decl of 435 SigD _ s 436 -> return (bs, cL l s : ss, ts, tfis, dfis, docs) 437 TyClD _ (FamDecl _ t) 438 -> return (bs, ss, cL l t : ts, tfis, dfis, docs) 439 InstD _ (TyFamInstD { tfid_inst = tfi }) 440 -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs) 441 InstD _ (DataFamInstD { dfid_inst = dfi }) 442 -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs) 443 DocD _ d 444 -> return (bs, ss, ts, tfis, dfis, cL l d : docs) 445 SpliceD _ d 446 -> addFatalError l $ 447 hang (text "Declaration splices are allowed only" <+> 448 text "at the top level:") 449 2 (ppr d) 450 _ -> pprPanic "cvBindsAndSigs" (ppr decl) } 451 452----------------------------------------------------------------------------- 453-- Group function bindings into equation groups 454 455getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] 456 -> (LHsBind GhcPs, [LHsDecl GhcPs]) 457-- Suppose (b',ds') = getMonoBind b ds 458-- ds is a list of parsed bindings 459-- b is a MonoBinds that has just been read off the front 460 461-- Then b' is the result of grouping more equations from ds that 462-- belong with b into a single MonoBinds, and ds' is the depleted 463-- list of parsed bindings. 464-- 465-- All Haddock comments between equations inside the group are 466-- discarded. 467-- 468-- No AndMonoBinds or EmptyMonoBinds here; just single equations 469 470getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) 471 , fun_matches = 472 MG { mg_alts = (dL->L _ mtchs1) } })) 473 binds 474 | has_args mtchs1 475 = go mtchs1 loc1 binds [] 476 where 477 go mtchs loc 478 ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) 479 , fun_matches = 480 MG { mg_alts = (dL->L _ mtchs2) } }))) 481 : binds) _ 482 | f1 == f2 = go (mtchs2 ++ mtchs) 483 (combineSrcSpans loc loc2) binds [] 484 go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls 485 = let doc_decls' = doc_decl : doc_decls 486 in go mtchs (combineSrcSpans loc loc2) binds doc_decls' 487 go mtchs loc binds doc_decls 488 = ( cL loc (makeFunBind fun_id1 (reverse mtchs)) 489 , (reverse doc_decls) ++ binds) 490 -- Reverse the final matches, to get it back in the right order 491 -- Do the same thing with the trailing doc comments 492 493getMonoBind bind binds = (bind, binds) 494 495has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool 496has_args [] = panic "RdrHsSyn:has_args" 497has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) 498 -- Don't group together FunBinds if they have 499 -- no arguments. This is necessary now that variable bindings 500 -- with no arguments are now treated as FunBinds rather 501 -- than pattern bindings (tests/rename/should_fail/rnfail002). 502has_args ((dL->L _ (XMatch nec)) : _) = noExtCon nec 503has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 504 505{- ********************************************************************** 506 507 #PrefixToHS-utils# Utilities for conversion 508 509 ********************************************************************* -} 510 511{- Note [Parsing data constructors is hard] 512~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 513 514The problem with parsing data constructors is that they look a lot like types. 515Compare: 516 517 (s1) data T = C t1 t2 518 (s2) type T = C t1 t2 519 520Syntactically, there's little difference between these declarations, except in 521(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. 522 523This similarity would pose no problem if we knew ahead of time if we are 524parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple 525(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing 526data constructors, and in other contexts (e.g. 'type' declarations) assume we 527are parsing type constructors. 528 529This simple rule does not work because of two problematic cases: 530 531 (p1) data T = C t1 t2 :+ t3 532 (p2) data T = C t1 t2 => t3 533 534In (p1) we encounter (:+) and it turns out we are parsing an infix data 535declaration, so (C t1 t2) is a type and 'C' is a type constructor. 536In (p2) we encounter (=>) and it turns out we are parsing an existential 537context, so (C t1 t2) is a constraint and 'C' is a type constructor. 538 539As the result, in order to determine whether (C t1 t2) declares a data 540constructor, a type, or a context, we would need unlimited lookahead which 541'happy' is not so happy with. 542 543To further complicate matters, the interpretation of (!) and (~) is different 544in constructors and types: 545 546 (b1) type T = C ! D 547 (b2) data T = C ! D 548 (b3) data T = C ! D => E 549 550In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At 551the same time, in (b2) it is a strictness annotation: 'C' is a data constructor 552with a single strict argument 'D'. For the programmer, these cases are usually 553easy to tell apart due to whitespace conventions: 554 555 (b2) data T = C !D -- no space after the bang hints that 556 -- it is a strictness annotation 557 558For the parser, on the other hand, this whitespace does not matter. We cannot 559tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited 560lookahead. 561 562The solution that accounts for all of these issues is to initially parse data 563declarations and types as a reversed list of TyEl: 564 565 data TyEl = TyElOpr RdrName 566 | TyElOpd (HsType GhcPs) 567 | TyElBang | TyElTilde 568 | ... 569 570For example, both occurences of (C ! D) in the following example are parsed 571into equal lists of TyEl: 572 573 data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D") 574 , TyElBang 575 , TyElOpd (HsTyVar "C") ] 576 577Note that elements are in reverse order. Also, 'C' is parsed as a type 578constructor (HsTyVar) even when it is a data constructor. We fix this in 579`tyConToDataCon`. 580 581By the time the list of TyEl is assembled, we have looked ahead enough to 582decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for 583data constructors). These functions are where the actual job of parsing is 584done. 585 586-} 587 588-- | Reinterpret a type constructor, including type operators, as a data 589-- constructor. 590-- See Note [Parsing data constructors is hard] 591tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) 592tyConToDataCon loc tc 593 | isTcOcc occ || isDataOcc occ 594 , isLexCon (occNameFS occ) 595 = return (cL loc (setRdrNameSpace tc srcDataName)) 596 597 | otherwise 598 = Left (loc, msg) 599 where 600 occ = rdrNameOcc tc 601 msg = text "Not a data constructor:" <+> quotes (ppr tc) 602 603mkPatSynMatchGroup :: Located RdrName 604 -> Located (OrdList (LHsDecl GhcPs)) 605 -> P (MatchGroup GhcPs (LHsExpr GhcPs)) 606mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = 607 do { matches <- mapM fromDecl (fromOL decls) 608 ; when (null matches) (wrongNumberErr loc) 609 ; return $ mkMatchGroup FromSource matches } 610 where 611 fromDecl (dL->L loc decl@(ValD _ (PatBind _ 612 pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) 613 rhs _))) = 614 do { unless (name == patsyn_name) $ 615 wrongNameBindingErr loc decl 616 ; match <- case details of 617 PrefixCon pats -> return $ Match { m_ext = noExtField 618 , m_ctxt = ctxt, m_pats = pats 619 , m_grhss = rhs } 620 where 621 ctxt = FunRhs { mc_fun = ln 622 , mc_fixity = Prefix 623 , mc_strictness = NoSrcStrict } 624 625 InfixCon p1 p2 -> return $ Match { m_ext = noExtField 626 , m_ctxt = ctxt 627 , m_pats = [p1, p2] 628 , m_grhss = rhs } 629 where 630 ctxt = FunRhs { mc_fun = ln 631 , mc_fixity = Infix 632 , mc_strictness = NoSrcStrict } 633 634 RecCon{} -> recordPatSynErr loc pat 635 ; return $ cL loc match } 636 fromDecl (dL->L loc decl) = extraDeclErr loc decl 637 638 extraDeclErr loc decl = 639 addFatalError loc $ 640 text "pattern synonym 'where' clause must contain a single binding:" $$ 641 ppr decl 642 643 wrongNameBindingErr loc decl = 644 addFatalError loc $ 645 text "pattern synonym 'where' clause must bind the pattern synonym's name" 646 <+> quotes (ppr patsyn_name) $$ ppr decl 647 648 wrongNumberErr loc = 649 addFatalError loc $ 650 text "pattern synonym 'where' clause cannot be empty" $$ 651 text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) 652 653recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a 654recordPatSynErr loc pat = 655 addFatalError loc $ 656 text "record syntax not supported for pattern synonym declarations:" $$ 657 ppr pat 658 659mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] 660 -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs 661 -> ConDecl GhcPs 662 663mkConDeclH98 name mb_forall mb_cxt args 664 = ConDeclH98 { con_ext = noExtField 665 , con_name = name 666 , con_forall = noLoc $ isJust mb_forall 667 , con_ex_tvs = mb_forall `orElse` [] 668 , con_mb_cxt = mb_cxt 669 , con_args = args 670 , con_doc = Nothing } 671 672mkGadtDecl :: [Located RdrName] 673 -> LHsType GhcPs -- Always a HsForAllTy 674 -> (ConDecl GhcPs, [AddAnn]) 675mkGadtDecl names ty 676 = (ConDeclGADT { con_g_ext = noExtField 677 , con_names = names 678 , con_forall = cL l $ isLHsForAllTy ty' 679 , con_qvars = mkHsQTvs tvs 680 , con_mb_cxt = mcxt 681 , con_args = args 682 , con_res_ty = res_ty 683 , con_doc = Nothing } 684 , anns1 ++ anns2) 685 where 686 (ty'@(dL->L l _),anns1) = peel_parens ty [] 687 (tvs, rho) = splitLHsForAllTyInvis ty' 688 (mcxt, tau, anns2) = split_rho rho [] 689 690 split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann 691 = (Just cxt, tau, ann) 692 split_rho (dL->L l (HsParTy _ ty)) ann 693 = split_rho ty (ann++mkParensApiAnn l) 694 split_rho tau ann 695 = (Nothing, tau, ann) 696 697 (args, res_ty) = split_tau tau 698 699 -- See Note [GADT abstract syntax] in GHC.Hs.Decls 700 split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) 701 = (RecCon (cL loc rf), res_ty) 702 split_tau tau 703 = (PrefixCon [], tau) 704 705 peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty 706 (ann++mkParensApiAnn l) 707 peel_parens ty ann = (ty, ann) 708 709 710setRdrNameSpace :: RdrName -> NameSpace -> RdrName 711-- ^ This rather gruesome function is used mainly by the parser. 712-- When parsing: 713-- 714-- > data T a = T | T1 Int 715-- 716-- we parse the data constructors as /types/ because of parser ambiguities, 717-- so then we need to change the /type constr/ to a /data constr/ 718-- 719-- The exact-name case /can/ occur when parsing: 720-- 721-- > data [] a = [] | a : [a] 722-- 723-- For the exact-name case we return an original name. 724setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) 725setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) 726setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) 727setRdrNameSpace (Exact n) ns 728 | Just thing <- wiredInNameTyThing_maybe n 729 = setWiredInNameSpace thing ns 730 -- Preserve Exact Names for wired-in things, 731 -- notably tuples and lists 732 733 | isExternalName n 734 = Orig (nameModule n) occ 735 736 | otherwise -- This can happen when quoting and then 737 -- splicing a fixity declaration for a type 738 = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) 739 where 740 occ = setOccNameSpace ns (nameOccName n) 741 742setWiredInNameSpace :: TyThing -> NameSpace -> RdrName 743setWiredInNameSpace (ATyCon tc) ns 744 | isDataConNameSpace ns 745 = ty_con_data_con tc 746 | isTcClsNameSpace ns 747 = Exact (getName tc) -- No-op 748 749setWiredInNameSpace (AConLike (RealDataCon dc)) ns 750 | isTcClsNameSpace ns 751 = data_con_ty_con dc 752 | isDataConNameSpace ns 753 = Exact (getName dc) -- No-op 754 755setWiredInNameSpace thing ns 756 = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) 757 758ty_con_data_con :: TyCon -> RdrName 759ty_con_data_con tc 760 | isTupleTyCon tc 761 , Just dc <- tyConSingleDataCon_maybe tc 762 = Exact (getName dc) 763 764 | tc `hasKey` listTyConKey 765 = Exact nilDataConName 766 767 | otherwise -- See Note [setRdrNameSpace for wired-in names] 768 = Unqual (setOccNameSpace srcDataName (getOccName tc)) 769 770data_con_ty_con :: DataCon -> RdrName 771data_con_ty_con dc 772 | let tc = dataConTyCon dc 773 , isTupleTyCon tc 774 = Exact (getName tc) 775 776 | dc `hasKey` nilDataConKey 777 = Exact listTyConName 778 779 | otherwise -- See Note [setRdrNameSpace for wired-in names] 780 = Unqual (setOccNameSpace tcClsName (getOccName dc)) 781 782-- | Replaces constraint tuple names with corresponding boxed ones. 783filterCTuple :: RdrName -> RdrName 784filterCTuple (Exact n) 785 | Just arity <- cTupleTyConNameArity_maybe n 786 = Exact $ tupleTyConName BoxedTuple arity 787filterCTuple rdr = rdr 788 789 790{- Note [setRdrNameSpace for wired-in names] 791~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 792In GHC.Types, which declares (:), we have 793 infixr 5 : 794The ambiguity about which ":" is meant is resolved by parsing it as a 795data constructor, but then using dataTcOccs to try the type constructor too; 796and that in turn calls setRdrNameSpace to change the name-space of ":" to 797tcClsName. There isn't a corresponding ":" type constructor, but it's painful 798to make setRdrNameSpace partial, so we just make an Unqual name instead. It 799really doesn't matter! 800-} 801 802eitherToP :: Either (SrcSpan, SDoc) a -> P a 803-- Adapts the Either monad to the P monad 804eitherToP (Left (loc, doc)) = addFatalError loc doc 805eitherToP (Right thing) = return thing 806 807checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] 808 -> P ( LHsQTyVars GhcPs -- the synthesized type variables 809 , [AddAnn] ) -- action which adds annotations 810-- ^ Check whether the given list of type parameters are all type variables 811-- (possibly with a kind signature). 812checkTyVars pp_what equals_or_where tc tparms 813 = do { (tvs, anns) <- fmap unzip $ mapM check tparms 814 ; return (mkHsQTvs tvs, concat anns) } 815 where 816 check (HsTypeArg _ ki@(L loc _)) 817 = addFatalError loc $ 818 vcat [ text "Unexpected type application" <+> 819 text "@" <> ppr ki 820 , text "In the" <+> pp_what <+> 821 ptext (sLit "declaration for") <+> quotes (ppr tc)] 822 check (HsValArg ty) = chkParens [] ty 823 check (HsArgPar sp) = addFatalError sp $ 824 vcat [text "Malformed" <+> pp_what 825 <+> text "declaration for" <+> quotes (ppr tc)] 826 -- Keep around an action for adjusting the annotations of extra parens 827 chkParens :: [AddAnn] -> LHsType GhcPs 828 -> P (LHsTyVarBndr GhcPs, [AddAnn]) 829 chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l 830 ++ acc) ty 831 chkParens acc ty = do 832 tv <- chk ty 833 return (tv, reverse acc) 834 835 -- Check that the name space is correct! 836 chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs) 837 chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) 838 | isRdrTyVar tv = return (cL l (KindedTyVar noExtField (cL lv tv) k)) 839 chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) 840 | isRdrTyVar tv = return (cL l (UserTyVar noExtField (cL ltv tv))) 841 chk t@(dL->L loc _) 842 = addFatalError loc $ 843 vcat [ text "Unexpected type" <+> quotes (ppr t) 844 , text "In the" <+> pp_what 845 <+> ptext (sLit "declaration for") <+> quotes tc' 846 , vcat[ (text "A" <+> pp_what 847 <+> ptext (sLit "declaration should have form")) 848 , nest 2 849 (pp_what 850 <+> tc' 851 <+> hsep (map text (takeList tparms allNameStrings)) 852 <+> equals_or_where) ] ] 853 854 -- Avoid printing a constraint tuple in the error message. Print 855 -- a plain old tuple instead (since that's what the user probably 856 -- wrote). See #14907 857 tc' = ppr $ fmap filterCTuple tc 858 859 860 861whereDots, equalsDots :: SDoc 862-- Second argument to checkTyVars 863whereDots = text "where ..." 864equalsDots = text "= ..." 865 866checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () 867checkDatatypeContext Nothing = return () 868checkDatatypeContext (Just c) 869 = do allowed <- getBit DatatypeContextsBit 870 unless allowed $ 871 addError (getLoc c) 872 (text "Illegal datatype context (use DatatypeContexts):" 873 <+> pprLHsContext c) 874 875type LRuleTyTmVar = Located RuleTyTmVar 876data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) 877-- ^ Essentially a wrapper for a @RuleBndr GhcPs@ 878 879-- turns RuleTyTmVars into RuleBnrs - this is straightforward 880mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] 881mkRuleBndrs = fmap (fmap cvt_one) 882 where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v 883 cvt_one (RuleTyTmVar v (Just sig)) = 884 RuleBndrSig noExtField v (mkLHsSigWcType sig) 885 886-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting 887mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs] 888mkRuleTyVarBndrs = fmap (fmap cvt_one) 889 where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExtField (fmap tm_to_ty v) 890 cvt_one (RuleTyTmVar v (Just sig)) 891 = KindedTyVar noExtField (fmap tm_to_ty v) sig 892 -- takes something in namespace 'varName' to something in namespace 'tvName' 893 tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) 894 tm_to_ty _ = panic "mkRuleTyVarBndrs" 895 896-- See note [Parsing explicit foralls in Rules] in Parser.y 897checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () 898checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) 899 where check (dL->L loc (Unqual occ)) = do 900 when ((occNameString occ ==) `any` ["forall","family","role"]) 901 (addFatalError loc (text $ "parse error on input " 902 ++ occNameString occ)) 903 check _ = panic "checkRuleTyVarBndrNames" 904 905checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) 906checkRecordSyntax lr@(dL->L loc r) 907 = do allowed <- getBit TraditionalRecordSyntaxBit 908 unless allowed $ addError loc $ 909 text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r 910 return lr 911 912-- | Check if the gadt_constrlist is empty. Only raise parse error for 913-- `data T where` to avoid affecting existing error message, see #8258. 914checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) 915 -> P (Located ([AddAnn], [LConDecl GhcPs])) 916checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. 917 = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax 918 unless gadtSyntax $ addError span $ vcat 919 [ text "Illegal keyword 'where' in data declaration" 920 , text "Perhaps you intended to use GADTs or a similar language" 921 , text "extension to enable syntax: data T where" 922 ] 923 return gadts 924checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. 925 926checkTyClHdr :: Bool -- True <=> class header 927 -- False <=> type header 928 -> LHsType GhcPs 929 -> P (Located RdrName, -- the head symbol (type or class name) 930 [LHsTypeArg GhcPs], -- parameters of head symbol 931 LexicalFixity, -- the declaration is in infix format 932 [AddAnn]) -- API Annotation for HsParTy when stripping parens 933-- Well-formedness check and decomposition of type and class heads. 934-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) 935-- Int :*: Bool into (:*:, [Int, Bool]) 936-- returning the pieces 937checkTyClHdr is_cls ty 938 = goL ty [] [] Prefix 939 where 940 goL (dL->L l ty) acc ann fix = go l ty acc ann fix 941 942 -- workaround to define '*' despite StarIsType 943 go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix 944 = do { warnStarBndr l 945 ; let name = mkOccName tcClsName (starSym isUni) 946 ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } 947 948 go _ (HsTyVar _ _ ltc@(dL->L _ tc)) acc ann fix 949 | isRdrTc tc = return (ltc, acc, fix, ann) 950 go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix 951 | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann) 952 go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix 953 go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix 954 go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix 955 go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix 956 = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann) 957 where 958 arity = length ts 959 tup_name | is_cls = cTupleTyConName arity 960 | otherwise = getName (tupleTyCon Boxed arity) 961 -- See Note [Unit tuples] in GHC.Hs.Types (TODO: is this still relevant?) 962 go l _ _ _ _ 963 = addFatalError l (text "Malformed head of type or class declaration:" 964 <+> ppr ty) 965 966-- | Yield a parse error if we have a function applied directly to a do block 967-- etc. and BlockArguments is not enabled. 968checkExpBlockArguments :: LHsExpr GhcPs -> PV () 969checkCmdBlockArguments :: LHsCmd GhcPs -> PV () 970(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) 971 where 972 checkExpr :: LHsExpr GhcPs -> PV () 973 checkExpr expr = case unLoc expr of 974 HsDo _ DoExpr _ -> check "do block" expr 975 HsDo _ MDoExpr _ -> check "mdo block" expr 976 HsLam {} -> check "lambda expression" expr 977 HsCase {} -> check "case expression" expr 978 HsLamCase {} -> check "lambda-case expression" expr 979 HsLet {} -> check "let expression" expr 980 HsIf {} -> check "if expression" expr 981 HsProc {} -> check "proc expression" expr 982 _ -> return () 983 984 checkCmd :: LHsCmd GhcPs -> PV () 985 checkCmd cmd = case unLoc cmd of 986 HsCmdLam {} -> check "lambda command" cmd 987 HsCmdCase {} -> check "case command" cmd 988 HsCmdIf {} -> check "if command" cmd 989 HsCmdLet {} -> check "let command" cmd 990 HsCmdDo {} -> check "do command" cmd 991 _ -> return () 992 993 check :: (HasSrcSpan a, Outputable a) => String -> a -> PV () 994 check element a = do 995 blockArguments <- getBit BlockArgumentsBit 996 unless blockArguments $ 997 addError (getLoc a) $ 998 text "Unexpected " <> text element <> text " in function application:" 999 $$ nest 4 (ppr a) 1000 $$ text "You could write it with parentheses" 1001 $$ text "Or perhaps you meant to enable BlockArguments?" 1002 1003-- | Validate the context constraints and break up a context into a list 1004-- of predicates. 1005-- 1006-- @ 1007-- (Eq a, Ord b) --> [Eq a, Ord b] 1008-- Eq a --> [Eq a] 1009-- (Eq a) --> [Eq a] 1010-- (((Eq a))) --> [Eq a] 1011-- @ 1012checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) 1013checkContext (dL->L l orig_t) 1014 = check [] (cL l orig_t) 1015 where 1016 check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) 1017 -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can 1018 -- be used as context constraints. 1019 = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto () 1020 1021 check anns (dL->L lp1 (HsParTy _ ty)) 1022 -- to be sure HsParTy doesn't get into the way 1023 = check anns' ty 1024 where anns' = if l == lp1 then anns 1025 else (anns ++ mkParensApiAnn lp1) 1026 1027 -- no need for anns, returning original 1028 check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t]) 1029 1030 msg = text "data constructor context" 1031 1032-- | Check recursively if there are any 'HsDocTy's in the given type. 1033-- This only works on a subset of types produced by 'btype_no_ops' 1034checkNoDocs :: SDoc -> LHsType GhcPs -> P () 1035checkNoDocs msg ty = go ty 1036 where 1037 go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki 1038 go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 1039 go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep 1040 [ text "Unexpected haddock", quotes (ppr ds) 1041 , text "on", msg, quotes (ppr t) ] 1042 go _ = pure () 1043 1044checkImportDecl :: Maybe (Located Token) 1045 -> Maybe (Located Token) 1046 -> P () 1047checkImportDecl mPre mPost = do 1048 let whenJust mg f = maybe (pure ()) f mg 1049 1050 importQualifiedPostEnabled <- getBit ImportQualifiedPostBit 1051 1052 -- Error if 'qualified' found in postpostive position and 1053 -- 'ImportQualifiedPost' is not in effect. 1054 whenJust mPost $ \post -> 1055 when (not importQualifiedPostEnabled) $ 1056 failOpNotEnabledImportQualifiedPost (getLoc post) 1057 1058 -- Error if 'qualified' occurs in both pre and postpositive 1059 -- positions. 1060 whenJust mPost $ \post -> 1061 when (isJust mPre) $ 1062 failOpImportQualifiedTwice (getLoc post) 1063 1064 -- Warn if 'qualified' found in prepositive position and 1065 -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. 1066 whenJust mPre $ \pre -> 1067 warnPrepositiveQualifiedModule (getLoc pre) 1068 1069-- ------------------------------------------------------------------------- 1070-- Checking Patterns. 1071 1072-- We parse patterns as expressions and check for valid patterns below, 1073-- converting the expression into a pattern at the same time. 1074 1075checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) 1076checkPattern = runPV . checkLPat 1077 1078checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) 1079checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat) 1080 1081checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) 1082checkLPat e@(dL->L l _) = checkPat l e [] 1083 1084checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs] 1085 -> PV (LPat GhcPs) 1086checkPat loc (dL->L l e@(PatBuilderVar (dL->L _ c))) args 1087 | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) 1088 | not (null args) && patIsRec c = 1089 localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $ 1090 patFail l (ppr e) 1091checkPat loc e args -- OK to let this happen even if bang-patterns 1092 -- are not enabled, because there is no valid 1093 -- non-bang-pattern parse of (C ! e) 1094 | Just (e', args') <- splitBang e 1095 = do { args'' <- mapM checkLPat args' 1096 ; checkPat loc e' (args'' ++ args) } 1097checkPat loc (dL->L _ (PatBuilderApp f e)) args 1098 = do p <- checkLPat e 1099 checkPat loc f (p : args) 1100checkPat loc (dL->L _ e) [] 1101 = do p <- checkAPat loc e 1102 return (cL loc p) 1103checkPat loc e _ 1104 = patFail loc (ppr e) 1105 1106checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) 1107checkAPat loc e0 = do 1108 nPlusKPatterns <- getBit NPlusKPatternsBit 1109 case e0 of 1110 PatBuilderPat p -> return p 1111 PatBuilderVar x -> return (VarPat noExtField x) 1112 1113 -- Overloaded numeric patterns (e.g. f 0 x = x) 1114 -- Negation is recorded separately, so that the literal is zero or +ve 1115 -- NB. Negative *primitive* literals are already handled by the lexer 1116 PatBuilderOverLit pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) 1117 1118 PatBuilderBang lb e -- (! x) 1119 -> do { hintBangPat loc e0 1120 ; e' <- checkLPat e 1121 ; addAnnotation loc AnnBang lb 1122 ; return (BangPat noExtField e') } 1123 1124 -- n+k patterns 1125 PatBuilderOpApp 1126 (dL->L nloc (PatBuilderVar (dL->L _ n))) 1127 (dL->L _ plus) 1128 (dL->L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) 1129 | nPlusKPatterns && (plus == plus_RDR) 1130 -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) 1131 1132 PatBuilderOpApp l (dL->L cl c) r 1133 | isRdrDataCon c -> do 1134 l <- checkLPat l 1135 r <- checkLPat r 1136 return (ConPatIn (cL cl c) (InfixCon l r)) 1137 1138 PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) 1139 _ -> patFail loc (ppr e0) 1140 1141placeHolderPunRhs :: DisambECP b => PV (Located b) 1142-- The RHS of a punned record field will be filled in by the renamer 1143-- It's better not to make it an error, in case we want to print it when 1144-- debugging 1145placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR) 1146 1147plus_RDR, pun_RDR :: RdrName 1148plus_RDR = mkUnqual varName (fsLit "+") -- Hack 1149pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") 1150 1151isBangRdr, isTildeRdr :: RdrName -> Bool 1152isBangRdr (Unqual occ) = occNameFS occ == fsLit "!" 1153isBangRdr _ = False 1154isTildeRdr = (==eqTyCon_RDR) 1155 1156checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) 1157 -> PV (LHsRecField GhcPs (LPat GhcPs)) 1158checkPatField (dL->L l fld) = do p <- checkLPat (hsRecFieldArg fld) 1159 return (cL l (fld { hsRecFieldArg = p })) 1160 1161patFail :: SrcSpan -> SDoc -> PV a 1162patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e 1163 1164patIsRec :: RdrName -> Bool 1165patIsRec e = e == mkUnqual varName (fsLit "rec") 1166 1167--------------------------------------------------------------------------- 1168-- Check Equation Syntax 1169 1170checkValDef :: SrcStrictness 1171 -> Located (PatBuilder GhcPs) 1172 -> Maybe (LHsType GhcPs) 1173 -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) 1174 -> P ([AddAnn],HsBind GhcPs) 1175 1176checkValDef _strictness lhs (Just sig) grhss 1177 -- x :: ty = rhs parses as a *pattern* binding 1178 = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat 1179 checkPatBind lhs' grhss 1180 1181checkValDef strictness lhs Nothing g@(dL->L l (_,grhss)) 1182 = do { mb_fun <- isFunLhs lhs 1183 ; case mb_fun of 1184 Just (fun, is_infix, pats, ann) -> 1185 checkFunBind strictness ann (getLoc lhs) 1186 fun is_infix pats (cL l grhss) 1187 Nothing -> do 1188 lhs' <- checkPattern lhs 1189 checkPatBind lhs' g } 1190 1191checkFunBind :: SrcStrictness 1192 -> [AddAnn] 1193 -> SrcSpan 1194 -> Located RdrName 1195 -> LexicalFixity 1196 -> [Located (PatBuilder GhcPs)] 1197 -> Located (GRHSs GhcPs (LHsExpr GhcPs)) 1198 -> P ([AddAnn],HsBind GhcPs) 1199checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) 1200 = do ps <- mapM checkPattern pats 1201 let match_span = combineSrcSpans lhs_loc rhs_span 1202 -- Add back the annotations stripped from any HsPar values in the lhs 1203 -- mapM_ (\a -> a match_span) ann 1204 return (ann, makeFunBind fun 1205 [cL match_span (Match { m_ext = noExtField 1206 , m_ctxt = FunRhs 1207 { mc_fun = fun 1208 , mc_fixity = is_infix 1209 , mc_strictness = strictness } 1210 , m_pats = ps 1211 , m_grhss = grhss })]) 1212 -- The span of the match covers the entire equation. 1213 -- That isn't quite right, but it'll do for now. 1214 1215makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] 1216 -> HsBind GhcPs 1217-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too 1218makeFunBind fn ms 1219 = FunBind { fun_ext = noExtField, 1220 fun_id = fn, 1221 fun_matches = mkMatchGroup FromSource ms, 1222 fun_co_fn = idHsWrapper, 1223 fun_tick = [] } 1224 1225checkPatBind :: LPat GhcPs 1226 -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) 1227 -> P ([AddAnn],HsBind GhcPs) 1228checkPatBind lhs (dL->L _ (_,grhss)) 1229 = return ([],PatBind noExtField lhs grhss ([],[])) 1230 1231checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) 1232checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) 1233 | isUnqual v 1234 , not (isDataOcc (rdrNameOcc v)) 1235 = return lrdr 1236 1237checkValSigLhs lhs@(dL->L l _) 1238 = addFatalError l ((text "Invalid type signature:" <+> 1239 ppr lhs <+> text ":: ...") 1240 $$ text hint) 1241 where 1242 hint | foreign_RDR `looks_like` lhs 1243 = "Perhaps you meant to use ForeignFunctionInterface?" 1244 | default_RDR `looks_like` lhs 1245 = "Perhaps you meant to use DefaultSignatures?" 1246 | pattern_RDR `looks_like` lhs 1247 = "Perhaps you meant to use PatternSynonyms?" 1248 | otherwise 1249 = "Should be of form <variable> :: <type>" 1250 1251 -- A common error is to forget the ForeignFunctionInterface flag 1252 -- so check for that, and suggest. cf #3805 1253 -- Sadly 'foreign import' still barfs 'parse error' because 1254 -- 'import' is a keyword 1255 looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s 1256 looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs 1257 looks_like _ _ = False 1258 1259 foreign_RDR = mkUnqual varName (fsLit "foreign") 1260 default_RDR = mkUnqual varName (fsLit "default") 1261 pattern_RDR = mkUnqual varName (fsLit "pattern") 1262 1263checkDoAndIfThenElse 1264 :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) 1265 => a -> Bool -> b -> Bool -> c -> PV () 1266checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr 1267 | semiThen || semiElse 1268 = do doAndIfThenElse <- getBit DoAndIfThenElseBit 1269 unless doAndIfThenElse $ do 1270 addError (combineLocs guardExpr elseExpr) 1271 (text "Unexpected semi-colons in conditional:" 1272 $$ nest 4 expr 1273 $$ text "Perhaps you meant to use DoAndIfThenElse?") 1274 | otherwise = return () 1275 where pprOptSemi True = semi 1276 pprOptSemi False = empty 1277 expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> 1278 text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> 1279 text "else" <+> ppr elseExpr 1280 1281 1282 -- The parser left-associates, so there should 1283 -- not be any OpApps inside the e's 1284splitBang :: Located (PatBuilder GhcPs) -> Maybe (Located (PatBuilder GhcPs), [Located (PatBuilder GhcPs)]) 1285-- Splits (f ! g a b) into (f, [(! g), a, b]) 1286splitBang (dL->L _ (PatBuilderOpApp l_arg op r_arg)) 1287 | isBangRdr (unLoc op) 1288 = Just (l_arg, cL l' (PatBuilderBang (getLoc op) arg1) : argns) 1289 where 1290 l' = combineLocs op arg1 1291 (arg1,argns) = split_bang r_arg [] 1292 split_bang (dL->L _ (PatBuilderApp f e)) es = split_bang f (e:es) 1293 split_bang e es = (e,es) 1294splitBang _ = Nothing 1295 1296-- See Note [isFunLhs vs mergeDataCon] 1297isFunLhs :: Located (PatBuilder GhcPs) 1298 -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) 1299-- A variable binding is parsed as a FunBind. 1300-- Just (fun, is_infix, arg_pats) if e is a function LHS 1301-- 1302-- The whole LHS is parsed as a single expression. 1303-- Any infix operators on the LHS will parse left-associatively 1304-- E.g. f !x y !z 1305-- will parse (rather strangely) as 1306-- (f ! x y) ! z 1307-- It's up to isFunLhs to sort out the mess 1308-- 1309-- a .!. !b 1310 1311isFunLhs e = go e [] [] 1312 where 1313 go (dL->L loc (PatBuilderVar (dL->L _ f))) es ann 1314 | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) 1315 go (dL->L _ (PatBuilderApp f e)) es ann = go f (e:es) ann 1316 go (dL->L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) 1317 1318 -- Things of the form `!x` are also FunBinds 1319 -- See Note [FunBind vs PatBind] 1320 go (dL->L _ (PatBuilderBang _ (L _ (PatBuilderVar (dL -> L l var))))) [] ann 1321 | not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) 1322 1323 -- For infix function defns, there should be only one infix *function* 1324 -- (though there may be infix *datacons* involved too). So we don't 1325 -- need fixity info to figure out which function is being defined. 1326 -- a `K1` b `op` c `K2` d 1327 -- must parse as 1328 -- (a `K1` b) `op` (c `K2` d) 1329 -- The renamer checks later that the precedences would yield such a parse. 1330 -- 1331 -- There is a complication to deal with bang patterns. 1332 -- 1333 -- ToDo: what about this? 1334 -- x + 1 `op` y = ... 1335 1336 go e@(L loc (PatBuilderOpApp l (dL->L loc' op) r)) es ann 1337 | Just (e',es') <- splitBang e 1338 = do { bang_on <- getBit BangPatBit 1339 ; if bang_on then go e' (es' ++ es) ann 1340 else return (Just (cL loc' op, Infix, (l:r:es), ann)) } 1341 -- No bangs; behave just like the next case 1342 | not (isRdrDataCon op) -- We have found the function! 1343 = return (Just (cL loc' op, Infix, (l:r:es), ann)) 1344 | otherwise -- Infix data con; keep going 1345 = do { mb_l <- go l es ann 1346 ; case mb_l of 1347 Just (op', Infix, j : k : es', ann') 1348 -> return (Just (op', Infix, j : op_app : es', ann')) 1349 where 1350 op_app = cL loc (PatBuilderOpApp k 1351 (cL loc' op) r) 1352 _ -> return Nothing } 1353 go _ _ _ = return Nothing 1354 1355-- | Either an operator or an operand. 1356data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) 1357 | TyElKindApp SrcSpan (LHsType GhcPs) 1358 -- See Note [TyElKindApp SrcSpan interpretation] 1359 | TyElTilde | TyElBang 1360 | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) 1361 | TyElDocPrev HsDocString 1362 1363 1364{- Note [TyElKindApp SrcSpan interpretation] 1365~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1366 1367A TyElKindApp captures type application written in haskell as 1368 1369 @ Foo 1370 1371where Foo is some type. 1372 1373The SrcSpan reflects both elements, and there are AnnAt and AnnVal API 1374Annotations attached to this SrcSpan for the specific locations of 1375each within it. 1376-} 1377 1378instance Outputable TyEl where 1379 ppr (TyElOpr name) = ppr name 1380 ppr (TyElOpd ty) = ppr ty 1381 ppr (TyElKindApp _ ki) = text "@" <> ppr ki 1382 ppr TyElTilde = text "~" 1383 ppr TyElBang = text "!" 1384 ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk 1385 ppr (TyElDocPrev doc) = ppr doc 1386 1387tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness) 1388tyElStrictness TyElTilde = Just (AnnTilde, SrcLazy) 1389tyElStrictness TyElBang = Just (AnnBang, SrcStrict) 1390tyElStrictness _ = Nothing 1391 1392-- | Extract a strictness/unpackedness annotation from the front of a reversed 1393-- 'TyEl' list. 1394pStrictMark 1395 :: [Located TyEl] -- reversed TyEl 1396 -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -} 1397 , [AddAnn] 1398 , [Located TyEl] {- remaining TyEl -}) 1399pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs) 1400 | Just (strAnnId, str) <- tyElStrictness x1 1401 , TyElUnpackedness (unpkAnns, prag, unpk) <- x2 1402 = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) 1403 , unpkAnns ++ [AddAnn strAnnId l1] 1404 , xs ) 1405pStrictMark ((dL->L l x1) : xs) 1406 | Just (strAnnId, str) <- tyElStrictness x1 1407 = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str) 1408 , [AddAnn strAnnId l] 1409 , xs ) 1410pStrictMark ((dL->L l x1) : xs) 1411 | TyElUnpackedness (anns, prag, unpk) <- x1 1412 = Just ( cL l (HsSrcBang prag unpk NoSrcStrict) 1413 , anns 1414 , xs ) 1415pStrictMark _ = Nothing 1416 1417pBangTy 1418 :: LHsType GhcPs -- a type to be wrapped inside HsBangTy 1419 -> [Located TyEl] -- reversed TyEl 1420 -> ( Bool {- has a strict mark been consumed? -} 1421 , LHsType GhcPs {- the resulting BangTy -} 1422 , P () {- add annotations -} 1423 , [Located TyEl] {- remaining TyEl -}) 1424pBangTy lt@(dL->L l1 _) xs = 1425 case pStrictMark xs of 1426 Nothing -> (False, lt, pure (), xs) 1427 Just (dL->L l2 strictMark, anns, xs') -> 1428 let bl = combineSrcSpans l1 l2 1429 bt = HsBangTy noExtField strictMark lt 1430 in (True, cL bl bt, addAnnsAt bl anns, xs') 1431 1432-- | Merge a /reversed/ and /non-empty/ soup of operators and operands 1433-- into a type. 1434-- 1435-- User input: @F x y + G a b * X@ 1436-- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F] 1437-- Output corresponds to what the user wrote assuming all operators are of the 1438-- same fixity and right-associative. 1439-- 1440-- It's a bit silly that we're doing it at all, as the renamer will have to 1441-- rearrange this, and it'd be easier to keep things separate. 1442-- 1443-- See Note [Parsing data constructors is hard] 1444mergeOps :: [Located TyEl] -> P (LHsType GhcPs) 1445mergeOps ((dL->L l1 (TyElOpd t)) : xs) 1446 | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs 1447 , null xs' -- We accept a BangTy only when there are no preceding TyEl. 1448 = addAnns >> return t' 1449mergeOps all_xs = go (0 :: Int) [] id all_xs 1450 where 1451 -- NB. When modifying clauses in 'go', make sure that the reasoning in 1452 -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct. 1453 1454 -- clause [unpk]: 1455 -- handle (NO)UNPACK pragmas 1456 go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = 1457 if not (null acc) && null xs 1458 then do { acc' <- eitherToP $ mergeOpsAcc acc 1459 ; let a = ops_acc acc' 1460 strictMark = HsSrcBang unpkSrc unpk NoSrcStrict 1461 bl = combineSrcSpans l (getLoc a) 1462 bt = HsBangTy noExtField strictMark a 1463 ; addAnnsAt bl anns 1464 ; return (cL bl bt) } 1465 else addFatalError l unpkError 1466 where 1467 unpkSDoc = case unpkSrc of 1468 NoSourceText -> ppr unpk 1469 SourceText str -> text str <> text " #-}" 1470 unpkError 1471 | not (null xs) = unpkSDoc <+> text "cannot appear inside a type." 1472 | null acc && k == 0 = unpkSDoc <+> text "must be applied to a type." 1473 | otherwise = 1474 -- See Note [Impossible case in mergeOps clause [unpk]] 1475 panic "mergeOps.UNPACK: impossible position" 1476 1477 -- clause [doc]: 1478 -- we do not expect to encounter any docs 1479 go _ _ _ ((dL->L l (TyElDocPrev _)):_) = 1480 failOpDocPrev l 1481 1482 -- to improve error messages, we do a bit of guesswork to determine if the 1483 -- user intended a '!' or a '~' as a strictness annotation 1484 go k acc ops_acc ((dL->L l x) : xs) 1485 | Just (_, str) <- tyElStrictness x 1486 , let guess [] = True 1487 guess ((dL->L _ (TyElOpd _)):_) = False 1488 guess ((dL->L _ (TyElOpr _)):_) = True 1489 guess ((dL->L _ (TyElKindApp _ _)):_) = False 1490 guess ((dL->L _ (TyElTilde)):_) = True 1491 guess ((dL->L _ (TyElBang)):_) = True 1492 guess ((dL->L _ (TyElUnpackedness _)):_) = True 1493 guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs' 1494 guess _ = panic "mergeOps.go.guess: Impossible Match" 1495 -- due to #15884 1496 in guess xs 1497 = if not (null acc) && (k > 1 || length acc > 1) 1498 then do { a <- eitherToP (mergeOpsAcc acc) 1499 ; failOpStrictnessCompound (cL l str) (ops_acc a) } 1500 else failOpStrictnessPosition (cL l str) 1501 1502 -- clause [opr]: 1503 -- when we encounter an operator, we must have accumulated 1504 -- something for its rhs, and there must be something left 1505 -- to build its lhs. 1506 go k acc ops_acc ((dL->L l (TyElOpr op)):xs) = 1507 if null acc || null (filter isTyElOpd xs) 1508 then failOpFewArgs (cL l op) 1509 else do { acc' <- eitherToP (mergeOpsAcc acc) 1510 ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs } 1511 where 1512 isTyElOpd (dL->L _ (TyElOpd _)) = True 1513 isTyElOpd _ = False 1514 1515 -- clause [opr.1]: interpret 'TyElTilde' as an operator 1516 go k acc ops_acc ((dL->L l TyElTilde):xs) = 1517 let op = eqTyCon_RDR 1518 in go k acc ops_acc (cL l (TyElOpr op):xs) 1519 1520 -- clause [opr.2]: interpret 'TyElBang' as an operator 1521 go k acc ops_acc ((dL->L l TyElBang):xs) = 1522 let op = mkUnqual tcClsName (fsLit "!") 1523 in go k acc ops_acc (cL l (TyElOpr op):xs) 1524 1525 -- clause [opd]: 1526 -- whenever an operand is encountered, it is added to the accumulator 1527 go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs 1528 1529 -- clause [tyapp]: 1530 -- whenever a type application is encountered, it is added to the accumulator 1531 go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs 1532 1533 -- clause [end] 1534 -- See Note [Non-empty 'acc' in mergeOps clause [end]] 1535 go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc) 1536 ; return (ops_acc acc') } 1537 1538 go _ _ _ _ = panic "mergeOps.go: Impossible Match" 1539 -- due to #15884 1540 1541mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] 1542 -> Either (SrcSpan, SDoc) (LHsType GhcPs) 1543mergeOpsAcc [] = panic "mergeOpsAcc: empty input" 1544mergeOpsAcc (HsTypeArg _ (L loc ki):_) 1545 = Left (loc, text "Unexpected type application:" <+> ppr ki) 1546mergeOpsAcc (HsValArg ty : xs) = go1 ty xs 1547 where 1548 go1 :: LHsType GhcPs 1549 -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)] 1550 -> Either (SrcSpan, SDoc) (LHsType GhcPs) 1551 go1 lhs [] = Right lhs 1552 go1 lhs (x:xs) = case x of 1553 HsValArg ty -> go1 (mkHsAppTy lhs ty) xs 1554 HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki 1555 in go1 ty xs 1556 HsArgPar _ -> go1 lhs xs 1557mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs 1558 1559{- Note [Impossible case in mergeOps clause [unpk]] 1560~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1561This case should never occur. Let us consider all possible 1562variations of 'acc', 'xs', and 'k': 1563 1564 acc xs k 1565============================== 1566 null | null 0 -- "must be applied to a type" 1567 null | not null 0 -- "must be applied to a type" 1568not null | null 0 -- successful parse 1569not null | not null 0 -- "cannot appear inside a type" 1570 null | null >0 -- handled in clause [opr] 1571 null | not null >0 -- "cannot appear inside a type" 1572not null | null >0 -- successful parse 1573not null | not null >0 -- "cannot appear inside a type" 1574 1575The (null acc && null xs && k>0) case is handled in clause [opr] 1576by the following check: 1577 1578 if ... || null (filter isTyElOpd xs) 1579 then failOpFewArgs (L l op) 1580 1581We know that this check has been performed because k>0, and by 1582the time we reach the end of the list (null xs), the only way 1583for (null acc) to hold is that there was not a single TyElOpd 1584between the operator and the end of the list. But this case is 1585caught by the check and reported as 'failOpFewArgs'. 1586-} 1587 1588{- Note [Non-empty 'acc' in mergeOps clause [end]] 1589~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1590In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc' 1591without a check. 1592 1593Running 'mergeOps' with an empty input list is forbidden, so we do not consider 1594this possibility. This means we'll hit at least one other clause before we 1595reach clause [end]. 1596 1597* Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit 1598 clause [end] from there. 1599* Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc' 1600 will be non-empty. 1601* Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going 1602 to hit clause [opd] at least once before we reach clause [end], making 'acc' 1603 non-empty. 1604* There are no other clauses. 1605 1606Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause 1607[end]. 1608 1609-} 1610 1611pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) 1612pInfixSide ((dL->L l (TyElOpd t)):xs) 1613 | (True, t', addAnns, xs') <- pBangTy (cL l t) xs 1614 = Just (t', addAnns, xs') 1615pInfixSide (el:xs1) 1616 | Just t1 <- pLHsTypeArg el 1617 = go [t1] xs1 1618 where 1619 go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] 1620 -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) 1621 go acc (el:xs) 1622 | Just t <- pLHsTypeArg el 1623 = go (t:acc) xs 1624 go acc xs = case mergeOpsAcc acc of 1625 Left _ -> Nothing 1626 Right acc' -> Just (acc', pure (), xs) 1627pInfixSide _ = Nothing 1628 1629pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs)) 1630pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a)) 1631pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a) 1632pLHsTypeArg _ = Nothing 1633 1634pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) 1635pDocPrev = go Nothing 1636 where 1637 go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) = 1638 go (mTrailingDoc `mplus` Just (cL l doc)) xs 1639 go mTrailingDoc xs = (mTrailingDoc, xs) 1640 1641orErr :: Maybe a -> b -> Either b a 1642orErr (Just a) _ = Right a 1643orErr Nothing b = Left b 1644 1645{- Note [isFunLhs vs mergeDataCon] 1646~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1647 1648When parsing a function LHS, we do not know whether to treat (!) as 1649a strictness annotation or an infix operator: 1650 1651 f ! a = ... 1652 1653Without -XBangPatterns, this parses as (!) f a = ... 1654 with -XBangPatterns, this parses as f (!a) = ... 1655 1656So in function declarations we opted to always parse as if -XBangPatterns 1657were off, and then rejig in 'isFunLhs'. 1658 1659There are two downsides to this approach: 1660 16611. It is not particularly elegant, as there's a point in our pipeline where 1662 the representation is awfully incorrect. For instance, 1663 f !a b !c = ... 1664 will be first parsed as 1665 (f ! a b) ! c = ... 1666 16672. There are cases that it fails to cover, for instance infix declarations: 1668 !a + !b = ... 1669 will trigger an error. 1670 1671Unfortunately, we cannot define different productions in the 'happy' grammar 1672depending on whether -XBangPatterns are enabled. 1673 1674When parsing data constructors, we face a similar issue: 1675 (a) data T1 = C ! D 1676 (b) data T2 = C ! D => ... 1677 1678In (a) the first bang is a strictness annotation, but in (b) it is a type 1679operator. A 'happy'-based parser does not have unlimited lookahead to check for 1680=>, so we must first parse (C ! D) into a common representation. 1681 1682If we tried to mirror the approach used in functions, we would parse both sides 1683of => as types, and then rejig. However, we take a different route and use an 1684intermediate data structure, a reversed list of 'TyEl'. 1685See Note [Parsing data constructors is hard] for details. 1686 1687This approach does not suffer from the issues of 'isFunLhs': 1688 16891. A sequence of 'TyEl' is a dedicated intermediate representation, not an 1690 incorrectly parsed type. Therefore, we do not have confusing states in our 1691 pipeline. (Except for representing data constructors as type variables). 1692 16932. We can handle infix data constructors with strictness annotations: 1694 data T a b = !a :+ !b 1695 1696-} 1697 1698 1699-- | Merge a /reversed/ and /non-empty/ soup of operators and operands 1700-- into a data constructor. 1701-- 1702-- User input: @C !A B -- ^ doc@ 1703-- Input to 'mergeDataCon': ["doc", B, !, A, C] 1704-- Output: (C, PrefixCon [!A, B], "doc") 1705-- 1706-- See Note [Parsing data constructors is hard] 1707-- See Note [isFunLhs vs mergeDataCon] 1708mergeDataCon 1709 :: [Located TyEl] 1710 -> P ( Located RdrName -- constructor name 1711 , HsConDeclDetails GhcPs -- constructor field information 1712 , Maybe LHsDocString -- docstring to go on the constructor 1713 ) 1714mergeDataCon all_xs = 1715 do { (addAnns, a) <- eitherToP res 1716 ; addAnns 1717 ; return a } 1718 where 1719 -- We start by splitting off the trailing documentation comment, 1720 -- if any exists. 1721 (mTrailingDoc, all_xs') = pDocPrev all_xs 1722 1723 -- Determine whether the trailing documentation comment exists and is the 1724 -- only docstring in this constructor declaration. 1725 -- 1726 -- When true, it means that it applies to the constructor itself: 1727 -- data T = C 1728 -- A 1729 -- B -- ^ Comment on C (singleDoc == True) 1730 -- 1731 -- When false, it means that it applies to the last field: 1732 -- data T = C -- ^ Comment on C 1733 -- A -- ^ Comment on A 1734 -- B -- ^ Comment on B (singleDoc == False) 1735 singleDoc = isJust mTrailingDoc && 1736 null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ] 1737 1738 -- The result of merging the list of reversed TyEl into a 1739 -- data constructor, along with [AddAnn]. 1740 res = goFirst all_xs' 1741 1742 -- Take the trailing docstring into account when interpreting 1743 -- the docstring near the constructor. 1744 -- 1745 -- data T = C -- ^ docstring right after C 1746 -- A 1747 -- B -- ^ trailing docstring 1748 -- 1749 -- 'mkConDoc' must be applied to the docstring right after C, so that it 1750 -- falls back to the trailing docstring when appropriate (see singleDoc). 1751 mkConDoc mDoc | singleDoc = mDoc `mplus` mTrailingDoc 1752 | otherwise = mDoc 1753 1754 -- The docstring for the last field of a data constructor. 1755 trailingFieldDoc | singleDoc = Nothing 1756 | otherwise = mTrailingDoc 1757 1758 goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] 1759 = do { data_con <- tyConToDataCon l tc 1760 ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } 1761 goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs) 1762 | (mConDoc, xs') <- pDocPrev xs 1763 , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs' 1764 = do { data_con <- tyConToDataCon l' tc 1765 ; let mDoc = mTrailingDoc `mplus` mConDoc 1766 ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) } 1767 goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] 1768 = return ( pure () 1769 , ( cL l (getRdrName (tupleDataCon Boxed (length ts))) 1770 , PrefixCon ts 1771 , mTrailingDoc ) ) 1772 goFirst ((dL->L l (TyElOpd t)):xs) 1773 | (_, t', addAnns, xs') <- pBangTy (cL l t) xs 1774 = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' 1775 goFirst (L l (TyElKindApp _ _):_) 1776 = goInfix Monoid.<> Left (l, kindAppErr) 1777 goFirst xs 1778 = go (pure ()) mTrailingDoc [] xs 1779 1780 go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] 1781 = do { data_con <- tyConToDataCon l tc 1782 ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } 1783 go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) = 1784 go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs 1785 go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs) 1786 | (_, t', addAnns', xs') <- pBangTy (cL l t) xs 1787 , t'' <- mkLHsDocTyMaybe t' mLastDoc 1788 = go (addAnns >> addAnns') Nothing (t'':ts) xs' 1789 go _ _ _ ((dL->L _ (TyElOpr _)):_) = 1790 -- Encountered an operator: backtrack to the beginning and attempt 1791 -- to parse as an infix definition. 1792 goInfix 1793 go _ _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) 1794 go _ _ _ _ = Left malformedErr 1795 where 1796 malformedErr = 1797 ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') 1798 , text "Cannot parse data constructor" <+> 1799 text "in a data/newtype declaration:" $$ 1800 nest 2 (hsep . reverse $ map ppr all_xs')) 1801 1802 goInfix = 1803 do { let xs0 = all_xs' 1804 ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr 1805 ; let (mOpDoc, xs2) = pDocPrev xs1 1806 ; (op, xs3) <- case xs2 of 1807 (dL->L l (TyElOpr op)) : xs3 -> 1808 do { data_con <- tyConToDataCon l op 1809 ; return (data_con, xs3) } 1810 _ -> Left malformedErr 1811 ; let (mLhsDoc, xs4) = pDocPrev xs3 1812 ; (lhs_t, lhs_addAnns, xs5) <- pInfixSide xs4 `orErr` malformedErr 1813 ; unless (null xs5) (Left malformedErr) 1814 ; let rhs = mkLHsDocTyMaybe rhs_t trailingFieldDoc 1815 lhs = mkLHsDocTyMaybe lhs_t mLhsDoc 1816 addAnns = lhs_addAnns >> rhs_addAnns 1817 ; return (addAnns, (op, InfixCon lhs rhs, mkConDoc mOpDoc)) } 1818 where 1819 malformedErr = 1820 ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') 1821 , text "Cannot parse an infix data constructor" <+> 1822 text "in a data/newtype declaration:" $$ 1823 nest 2 (hsep . reverse $ map ppr all_xs')) 1824 1825 kindAppErr = 1826 text "Unexpected kind application" <+> 1827 text "in a data/newtype declaration:" $$ 1828 nest 2 (hsep . reverse $ map ppr all_xs') 1829 1830--------------------------------------------------------------------------- 1831-- | Check for monad comprehensions 1832-- 1833-- If the flag MonadComprehensions is set, return a 'MonadComp' context, 1834-- otherwise use the usual 'ListComp' context 1835 1836checkMonadComp :: PV (HsStmtContext Name) 1837checkMonadComp = do 1838 monadComprehensions <- getBit MonadComprehensionsBit 1839 return $ if monadComprehensions 1840 then MonadComp 1841 else ListComp 1842 1843-- ------------------------------------------------------------------------- 1844-- Expression/command/pattern ambiguity. 1845-- See Note [Ambiguous syntactic categories] 1846-- 1847 1848-- See Note [Parser-Validator] 1849-- See Note [Ambiguous syntactic categories] 1850newtype ECP = 1851 ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) } 1852 1853runECP_P :: DisambECP b => ECP -> P (Located b) 1854runECP_P p = runPV (runECP_PV p) 1855 1856ecpFromExp :: LHsExpr GhcPs -> ECP 1857ecpFromExp a = ECP (ecpFromExp' a) 1858 1859ecpFromCmd :: LHsCmd GhcPs -> ECP 1860ecpFromCmd a = ECP (ecpFromCmd' a) 1861 1862-- | Disambiguate infix operators. 1863-- See Note [Ambiguous syntactic categories] 1864class DisambInfixOp b where 1865 mkHsVarOpPV :: Located RdrName -> PV (Located b) 1866 mkHsConOpPV :: Located RdrName -> PV (Located b) 1867 mkHsInfixHolePV :: SrcSpan -> PV (Located b) 1868 1869instance p ~ GhcPs => DisambInfixOp (HsExpr p) where 1870 mkHsVarOpPV v = return $ cL (getLoc v) (HsVar noExtField v) 1871 mkHsConOpPV v = return $ cL (getLoc v) (HsVar noExtField v) 1872 mkHsInfixHolePV l = return $ cL l hsHoleExpr 1873 1874instance DisambInfixOp RdrName where 1875 mkHsConOpPV (dL->L l v) = return $ cL l v 1876 mkHsVarOpPV (dL->L l v) = return $ cL l v 1877 mkHsInfixHolePV l = 1878 addFatalError l $ text "Invalid infix hole, expected an infix operator" 1879 1880-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are 1881-- parsing an expression, a command, or a pattern. 1882-- See Note [Ambiguous syntactic categories] 1883class b ~ (Body b) GhcPs => DisambECP b where 1884 -- | See Note [Body in DisambECP] 1885 type Body b :: * -> * 1886 -- | Return a command without ambiguity, or fail in a non-command context. 1887 ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) 1888 -- | Return an expression without ambiguity, or fail in a non-expression context. 1889 ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) 1890 -- | Disambiguate "\... -> ..." (lambda) 1891 mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) 1892 -- | Disambiguate "let ... in ..." 1893 mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) 1894 -- | Infix operator representation 1895 type InfixOp b 1896 -- | Bring superclass constraints on FunArg into scope. 1897 -- See Note [UndecidableSuperClasses for associated types] 1898 superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) 1899 -- | Disambiguate "f # x" (infix operator) 1900 mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b) 1901 -- | Disambiguate "case ... of ..." 1902 mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b) 1903 -- | Function argument representation 1904 type FunArg b 1905 -- | Bring superclass constraints on FunArg into scope. 1906 -- See Note [UndecidableSuperClasses for associated types] 1907 superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b) 1908 -- | Disambiguate "f x" (function application) 1909 mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b) 1910 -- | Disambiguate "if ... then ... else ..." 1911 mkHsIfPV :: SrcSpan 1912 -> LHsExpr GhcPs 1913 -> Bool -- semicolon? 1914 -> Located b 1915 -> Bool -- semicolon? 1916 -> Located b 1917 -> PV (Located b) 1918 -- | Disambiguate "do { ... }" (do notation) 1919 mkHsDoPV :: SrcSpan -> Located [LStmt GhcPs (Located b)] -> PV (Located b) 1920 -- | Disambiguate "( ... )" (parentheses) 1921 mkHsParPV :: SrcSpan -> Located b -> PV (Located b) 1922 -- | Disambiguate a variable "f" or a data constructor "MkF". 1923 mkHsVarPV :: Located RdrName -> PV (Located b) 1924 -- | Disambiguate a monomorphic literal 1925 mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) 1926 -- | Disambiguate an overloaded literal 1927 mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b) 1928 -- | Disambiguate a wildcard 1929 mkHsWildCardPV :: SrcSpan -> PV (Located b) 1930 -- | Disambiguate "a :: t" (type annotation) 1931 mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) 1932 -- | Disambiguate "[a,b,c]" (list syntax) 1933 mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b) 1934 -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) 1935 mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) 1936 -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) 1937 mkHsRecordPV :: 1938 SrcSpan -> 1939 SrcSpan -> 1940 Located b -> 1941 ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> 1942 PV (Located b) 1943 -- | Disambiguate "-a" (negation) 1944 mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) 1945 -- | Disambiguate "(# a)" (right operator section) 1946 mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b) 1947 -- | Disambiguate "(a -> b)" (view pattern) 1948 mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b) 1949 -- | Disambiguate "a@b" (as-pattern) 1950 mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) 1951 -- | Disambiguate "~a" (lazy pattern) 1952 mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) 1953 -- | Disambiguate tuple sections and unboxed sums 1954 mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) 1955 1956{- Note [UndecidableSuperClasses for associated types] 1957~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1958Assume we have a class C with an associated type T: 1959 1960 class C a where 1961 type T a 1962 ... 1963 1964If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: 1965 1966 {-# LANGUAGE UndecidableSuperClasses #-} 1967 class C (T a) => C a where 1968 type T a 1969 ... 1970 1971Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes 1972making GHC loop. The workaround is to bring this constraint into scope 1973manually with a helper method: 1974 1975 class C a where 1976 type T a 1977 superT :: (C (T a) => r) -> r 1978 1979In order to avoid ambiguous types, 'r' must mention 'a'. 1980 1981For consistency, we use this approach for all constraints on associated types, 1982even when -XUndecidableSuperClasses are not required. 1983-} 1984 1985{- Note [Body in DisambECP] 1986~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1987There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that 1988require their argument to take a form of (body GhcPs) for some (body :: * -> 1989*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the 1990superclass constraints of DisambECP. 1991 1992The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop 1993this requirement. It is possible and would allow removing the type index of 1994PatBuilder, but leads to worse type inference, breaking some code in the 1995typechecker. 1996-} 1997 1998instance p ~ GhcPs => DisambECP (HsCmd p) where 1999 type Body (HsCmd p) = HsCmd 2000 ecpFromCmd' = return 2001 ecpFromExp' (dL-> L l e) = cmdFail l (ppr e) 2002 mkHsLamPV l mg = return $ cL l (HsCmdLam noExtField mg) 2003 mkHsLetPV l bs e = return $ cL l (HsCmdLet noExtField bs e) 2004 type InfixOp (HsCmd p) = HsExpr p 2005 superInfixOp m = m 2006 mkHsOpAppPV l c1 op c2 = do 2007 let cmdArg c = cL (getLoc c) $ HsCmdTop noExtField c 2008 return $ cL l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] 2009 mkHsCasePV l c mg = return $ cL l (HsCmdCase noExtField c mg) 2010 type FunArg (HsCmd p) = HsExpr p 2011 superFunArg m = m 2012 mkHsAppPV l c e = do 2013 checkCmdBlockArguments c 2014 checkExpBlockArguments e 2015 return $ cL l (HsCmdApp noExtField c e) 2016 mkHsIfPV l c semi1 a semi2 b = do 2017 checkDoAndIfThenElse c semi1 a semi2 b 2018 return $ cL l (mkHsCmdIf c a b) 2019 mkHsDoPV l stmts = return $ cL l (HsCmdDo noExtField stmts) 2020 mkHsParPV l c = return $ cL l (HsCmdPar noExtField c) 2021 mkHsVarPV (dL->L l v) = cmdFail l (ppr v) 2022 mkHsLitPV (dL->L l a) = cmdFail l (ppr a) 2023 mkHsOverLitPV (dL->L l a) = cmdFail l (ppr a) 2024 mkHsWildCardPV l = cmdFail l (text "_") 2025 mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) 2026 mkHsExplicitListPV l xs = cmdFail l $ 2027 brackets (fsep (punctuate comma (map ppr xs))) 2028 mkHsSplicePV (dL->L l sp) = cmdFail l (ppr sp) 2029 mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $ 2030 ppr a <+> ppr (mk_rec_fields fbinds ddLoc) 2031 mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) 2032 mkHsSectionR_PV l op c = cmdFail l $ 2033 let pp_op = fromMaybe (panic "cannot print infix operator") 2034 (ppr_infix_expr (unLoc op)) 2035 in pp_op <> ppr c 2036 mkHsViewPatPV l a b = cmdFail l $ 2037 ppr a <+> text "->" <+> ppr b 2038 mkHsAsPatPV l v c = cmdFail l $ 2039 pprPrefixOcc (unLoc v) <> text "@" <> ppr c 2040 mkHsLazyPatPV l c = cmdFail l $ 2041 text "~" <> ppr c 2042 mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) 2043 2044cmdFail :: SrcSpan -> SDoc -> PV a 2045cmdFail loc e = addFatalError loc $ 2046 hang (text "Parse error in command:") 2 (ppr e) 2047 2048instance p ~ GhcPs => DisambECP (HsExpr p) where 2049 type Body (HsExpr p) = HsExpr 2050 ecpFromCmd' (dL -> L l c) = do 2051 addError l $ vcat 2052 [ text "Arrow command found where an expression was expected:", 2053 nest 2 (ppr c) ] 2054 return (cL l hsHoleExpr) 2055 ecpFromExp' = return 2056 mkHsLamPV l mg = return $ cL l (HsLam noExtField mg) 2057 mkHsLetPV l bs c = return $ cL l (HsLet noExtField bs c) 2058 type InfixOp (HsExpr p) = HsExpr p 2059 superInfixOp m = m 2060 mkHsOpAppPV l e1 op e2 = do 2061 return $ cL l $ OpApp noExtField e1 op e2 2062 mkHsCasePV l e mg = return $ cL l (HsCase noExtField e mg) 2063 type FunArg (HsExpr p) = HsExpr p 2064 superFunArg m = m 2065 mkHsAppPV l e1 e2 = do 2066 checkExpBlockArguments e1 2067 checkExpBlockArguments e2 2068 return $ cL l (HsApp noExtField e1 e2) 2069 mkHsIfPV l c semi1 a semi2 b = do 2070 checkDoAndIfThenElse c semi1 a semi2 b 2071 return $ cL l (mkHsIf c a b) 2072 mkHsDoPV l stmts = return $ cL l (HsDo noExtField DoExpr stmts) 2073 mkHsParPV l e = return $ cL l (HsPar noExtField e) 2074 mkHsVarPV v@(getLoc -> l) = return $ cL l (HsVar noExtField v) 2075 mkHsLitPV (dL->L l a) = return $ cL l (HsLit noExtField a) 2076 mkHsOverLitPV (dL->L l a) = return $ cL l (HsOverLit noExtField a) 2077 mkHsWildCardPV l = return $ cL l hsHoleExpr 2078 mkHsTySigPV l a sig = return $ cL l (ExprWithTySig noExtField a (mkLHsSigWcType sig)) 2079 mkHsExplicitListPV l xs = return $ cL l (ExplicitList noExtField Nothing xs) 2080 mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp 2081 mkHsRecordPV l lrec a (fbinds, ddLoc) = do 2082 r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc) 2083 checkRecordSyntax (cL l r) 2084 mkHsNegAppPV l a = return $ cL l (NegApp noExtField a noSyntaxExpr) 2085 mkHsSectionR_PV l op e = return $ cL l (SectionR noExtField op e) 2086 mkHsViewPatPV l a b = patSynErr l (ppr a <+> text "->" <+> ppr b) empty 2087 mkHsAsPatPV l v e = do 2088 opt_TypeApplications <- getBit TypeApplicationsBit 2089 let msg | opt_TypeApplications 2090 = "Type application syntax requires a space before '@'" 2091 | otherwise 2092 = "Did you mean to enable TypeApplications?" 2093 patSynErr l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) (text msg) 2094 mkHsLazyPatPV l e = patSynErr l (text "~" <> ppr e) empty 2095 mkSumOrTuplePV = mkSumOrTupleExpr 2096 2097patSynErr :: SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs) 2098patSynErr l e explanation = 2099 do { addError l $ 2100 sep [text "Pattern syntax in expression context:", 2101 nest 4 (ppr e)] $$ 2102 explanation 2103 ; return (cL l hsHoleExpr) } 2104 2105hsHoleExpr :: HsExpr (GhcPass id) 2106hsHoleExpr = HsUnboundVar noExtField (TrueExprHole (mkVarOcc "_")) 2107 2108-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] 2109data PatBuilder p 2110 = PatBuilderPat (Pat p) 2111 | PatBuilderBang SrcSpan (Located (PatBuilder p)) 2112 | PatBuilderPar (Located (PatBuilder p)) 2113 | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) 2114 | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) 2115 | PatBuilderVar (Located RdrName) 2116 | PatBuilderOverLit (HsOverLit GhcPs) 2117 2118patBuilderBang :: SrcSpan -> Located (PatBuilder p) -> Located (PatBuilder p) 2119patBuilderBang bang p = 2120 cL (bang `combineSrcSpans` getLoc p) $ 2121 PatBuilderBang bang p 2122 2123instance Outputable (PatBuilder GhcPs) where 2124 ppr (PatBuilderPat p) = ppr p 2125 ppr (PatBuilderBang _ (L _ p)) = text "!" <+> ppr p 2126 ppr (PatBuilderPar (L _ p)) = parens (ppr p) 2127 ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 2128 ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2 2129 ppr (PatBuilderVar v) = ppr v 2130 ppr (PatBuilderOverLit l) = ppr l 2131 2132instance DisambECP (PatBuilder GhcPs) where 2133 type Body (PatBuilder GhcPs) = PatBuilder 2134 ecpFromCmd' (dL-> L l c) = 2135 addFatalError l $ 2136 text "Command syntax in pattern:" <+> ppr c 2137 ecpFromExp' (dL-> L l e) = 2138 addFatalError l $ 2139 text "Expression syntax in pattern:" <+> ppr e 2140 mkHsLamPV l _ = addFatalError l $ 2141 text "Lambda-syntax in pattern." $$ 2142 text "Pattern matching on functions is not possible." 2143 mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern" 2144 type InfixOp (PatBuilder GhcPs) = RdrName 2145 superInfixOp m = m 2146 mkHsOpAppPV l p1 op p2 = do 2147 warnSpaceAfterBang op (getLoc p2) 2148 return $ cL l $ PatBuilderOpApp p1 op p2 2149 mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern" 2150 type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs 2151 superFunArg m = m 2152 mkHsAppPV l p1 p2 = return $ cL l (PatBuilderApp p1 p2) 2153 mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern" 2154 mkHsDoPV l _ = addFatalError l $ text "do-notation in pattern" 2155 mkHsParPV l p = return $ cL l (PatBuilderPar p) 2156 mkHsVarPV v@(getLoc -> l) = return $ cL l (PatBuilderVar v) 2157 mkHsLitPV lit@(dL->L l a) = do 2158 checkUnboxedStringLitPat lit 2159 return $ cL l (PatBuilderPat (LitPat noExtField a)) 2160 mkHsOverLitPV (dL->L l a) = return $ cL l (PatBuilderOverLit a) 2161 mkHsWildCardPV l = return $ cL l (PatBuilderPat (WildPat noExtField)) 2162 mkHsTySigPV l b sig = do 2163 p <- checkLPat b 2164 return $ cL l (PatBuilderPat (SigPat noExtField p (mkLHsSigWcType sig))) 2165 mkHsExplicitListPV l xs = do 2166 ps <- traverse checkLPat xs 2167 return (cL l (PatBuilderPat (ListPat noExtField ps))) 2168 mkHsSplicePV (dL->L l sp) = return $ cL l (PatBuilderPat (SplicePat noExtField sp)) 2169 mkHsRecordPV l _ a (fbinds, ddLoc) = do 2170 r <- mkPatRec a (mk_rec_fields fbinds ddLoc) 2171 checkRecordSyntax (cL l r) 2172 mkHsNegAppPV l (dL->L lp p) = do 2173 lit <- case p of 2174 PatBuilderOverLit pos_lit -> return (cL lp pos_lit) 2175 _ -> patFail l (text "-" <> ppr p) 2176 return $ cL l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) 2177 mkHsSectionR_PV l op p 2178 | isBangRdr (unLoc op) = return $ cL l $ PatBuilderBang (getLoc op) p 2179 | otherwise = patFail l (pprInfixOcc (unLoc op) <> ppr p) 2180 mkHsViewPatPV l a b = do 2181 p <- checkLPat b 2182 return $ cL l (PatBuilderPat (ViewPat noExtField a p)) 2183 mkHsAsPatPV l v e = do 2184 p <- checkLPat e 2185 return $ cL l (PatBuilderPat (AsPat noExtField v p)) 2186 mkHsLazyPatPV l e = do 2187 p <- checkLPat e 2188 return $ cL l (PatBuilderPat (LazyPat noExtField p)) 2189 mkSumOrTuplePV = mkSumOrTuplePat 2190 2191checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV () 2192checkUnboxedStringLitPat (dL->L loc lit) = 2193 case lit of 2194 HsStringPrim _ _ -- Trac #13260 2195 -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit) 2196 _ -> return () 2197 2198mkPatRec :: 2199 Located (PatBuilder GhcPs) -> 2200 HsRecFields GhcPs (Located (PatBuilder GhcPs)) -> 2201 PV (PatBuilder GhcPs) 2202mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) 2203 | isRdrDataCon (unLoc c) 2204 = do fs <- mapM checkPatField fs 2205 return (PatBuilderPat (ConPatIn c (RecCon (HsRecFields fs dd)))) 2206mkPatRec p _ = 2207 addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p 2208 2209-- | Warn about missing space after bang 2210warnSpaceAfterBang :: Located RdrName -> SrcSpan -> PV () 2211warnSpaceAfterBang (dL->L opLoc op) argLoc = do 2212 bang_on <- getBit BangPatBit 2213 when (not bang_on && noSpace && isBangRdr op) $ 2214 addWarning Opt_WarnSpaceAfterBang span msg 2215 where 2216 span = combineSrcSpans opLoc argLoc 2217 noSpace = srcSpanEnd opLoc == srcSpanStart argLoc 2218 msg = text "Did you forget to enable BangPatterns?" $$ 2219 text "If you mean to bind (!) then perhaps you want" $$ 2220 text "to add a space after the bang for clarity." 2221 2222{- Note [Ambiguous syntactic categories] 2223~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2224 2225There are places in the grammar where we do not know whether we are parsing an 2226expression or a pattern without unlimited lookahead (which we do not have in 2227'happy'): 2228 2229View patterns: 2230 2231 f (Con a b ) = ... -- 'Con a b' is a pattern 2232 f (Con a b -> x) = ... -- 'Con a b' is an expression 2233 2234do-notation: 2235 2236 do { Con a b <- x } -- 'Con a b' is a pattern 2237 do { Con a b } -- 'Con a b' is an expression 2238 2239Guards: 2240 2241 x | True <- p && q = ... -- 'True' is a pattern 2242 x | True = ... -- 'True' is an expression 2243 2244Top-level value/function declarations (FunBind/PatBind): 2245 2246 f !a -- TH splice 2247 f !a = ... -- function declaration 2248 2249 Until we encounter the = sign, we don't know if it's a top-level 2250 TemplateHaskell splice where ! is an infix operator, or if it's a function 2251 declaration where ! is a strictness annotation. 2252 2253There are also places in the grammar where we do not know whether we are 2254parsing an expression or a command: 2255 2256 proc x -> do { (stuff) -< x } -- 'stuff' is an expression 2257 proc x -> do { (stuff) } -- 'stuff' is a command 2258 2259 Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' 2260 as an expression or a command. 2261 2262In fact, do-notation is subject to both ambiguities: 2263 2264 proc x -> do { (stuff) -< x } -- 'stuff' is an expression 2265 proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern 2266 proc x -> do { (stuff) } -- 'stuff' is a command 2267 2268There are many possible solutions to this problem. For an overview of the ones 2269we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives] 2270 2271The solution that keeps basic definitions (such as HsExpr) clean, keeps the 2272concerns local to the parser, and does not require duplication of hsSyn types, 2273or an extra pass over the entire AST, is to parse into an overloaded 2274parser-validator (a so-called tagless final encoding): 2275 2276 class DisambECP b where ... 2277 instance p ~ GhcPs => DisambECP (HsCmd p) where ... 2278 instance p ~ GhcPs => DisambECP (HsExp p) where ... 2279 instance p ~ GhcPs => DisambECP (PatBuilder p) where ... 2280 2281The 'DisambECP' class contains functions to build and validate 'b'. For example, 2282to add parentheses we have: 2283 2284 mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) 2285 2286'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for 2287expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, 2288see Note [PatBuilder]). 2289 2290Consider the 'alts' production used to parse case-of alternatives: 2291 2292 alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } 2293 : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } 2294 | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } 2295 2296We abstract over LHsExpr GhcPs, and it becomes: 2297 2298 alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } 2299 : alts1 { $1 >>= \ $1 -> 2300 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } 2301 | ';' alts { $2 >>= \ $2 -> 2302 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } 2303 2304Compared to the initial definition, the added bits are: 2305 2306 forall b. DisambECP b => PV ( ... ) -- in the type signature 2307 $1 >>= \ $1 -> return $ -- in one reduction rule 2308 $2 >>= \ $2 -> return $ -- in another reduction rule 2309 2310The overhead is constant relative to the size of the rest of the reduction 2311rule, so this approach scales well to large parser productions. 2312 2313-} 2314 2315 2316{- Note [Resolving parsing ambiguities: non-taken alternatives] 2317~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2318 2319Alternative I, extra constructors in GHC.Hs.Expr 2320------------------------------------------------ 2321We could add extra constructors to HsExpr to represent command-specific and 2322pattern-specific syntactic constructs. Under this scheme, we parse patterns 2323and commands as expressions and rejig later. This is what GHC used to do, and 2324it polluted 'HsExpr' with irrelevant constructors: 2325 2326 * for commands: 'HsArrForm', 'HsArrApp' 2327 * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat' 2328 2329(As of now, we still do that for patterns, but we plan to fix it). 2330 2331There are several issues with this: 2332 2333 * The implementation details of parsing are leaking into hsSyn definitions. 2334 2335 * Code that uses HsExpr has to panic on these impossible-after-parsing cases. 2336 2337 * HsExpr is arbitrarily selected as the extension basis. Why not extend 2338 HsCmd or HsPat with extra constructors instead? 2339 2340 * We cannot handle corner cases. For instance, the following function 2341 declaration LHS is not a valid expression (see #1087): 2342 2343 !a + !b = ... 2344 2345 * There are points in the pipeline where the representation was awfully 2346 incorrect. For instance, 2347 2348 f !a b !c = ... 2349 2350 is first parsed as 2351 2352 (f ! a b) ! c = ... 2353 2354 2355Alternative II, extra constructors in GHC.Hs.Expr for GhcPs 2356----------------------------------------------------------- 2357We could address some of the problems with Alternative I by using Trees That 2358Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to 2359the output of parsing, not to its intermediate results, so we wouldn't want 2360them there either. 2361 2362Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs 2363--------------------------------------------------------------- 2364We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. 2365Unfortunately, creating a new pass would significantly bloat conversion code 2366and slow down the compiler by adding another linear-time pass over the entire 2367AST. For example, in order to build HsExpr GhcPrePs, we would need to build 2368HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds 2369GhcPrePs. 2370 2371 2372Alternative IV, sum type and bottom-up data flow 2373------------------------------------------------ 2374Expressions and commands are disjoint. There are no user inputs that could be 2375interpreted as either an expression or a command depending on outer context: 2376 2377 5 -- definitely an expression 2378 x -< y -- definitely a command 2379 2380Even though we have both 'HsLam' and 'HsCmdLam', we can look at 2381the body to disambiguate: 2382 2383 \p -> 5 -- definitely an expression 2384 \p -> x -< y -- definitely a command 2385 2386This means we could use a bottom-up flow of information to determine 2387whether we are parsing an expression or a command, using a sum type 2388for intermediate results: 2389 2390 Either (LHsExpr GhcPs) (LHsCmd GhcPs) 2391 2392There are two problems with this: 2393 2394 * We cannot handle the ambiguity between expressions and 2395 patterns, which are not disjoint. 2396 2397 * Bottom-up flow of information leads to poor error messages. Consider 2398 2399 if ... then 5 else (x -< y) 2400 2401 Do we report that '5' is not a valid command or that (x -< y) is not a 2402 valid expression? It depends on whether we want the entire node to be 2403 'HsIf' or 'HsCmdIf', and this information flows top-down, from the 2404 surrounding parsing context (are we in 'proc'?) 2405 2406Alternative V, backtracking with parser combinators 2407--------------------------------------------------- 2408One might think we could sidestep the issue entirely by using a backtracking 2409parser and doing something along the lines of (try pExpr <|> pPat). 2410 2411Turns out, this wouldn't work very well, as there can be patterns inside 2412expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns 2413(e.g. view patterns). To handle this, we would need to backtrack while 2414backtracking, and unbound levels of backtracking lead to very fragile 2415performance. 2416 2417Alternative VI, an intermediate data type 2418----------------------------------------- 2419There are common syntactic elements of expressions, commands, and patterns 2420(e.g. all of them must have balanced parentheses), and we can capture this 2421common structure in an intermediate data type, Frame: 2422 2423data Frame 2424 = FrameVar RdrName 2425 -- ^ Identifier: Just, map, BS.length 2426 | FrameTuple [LTupArgFrame] Boxity 2427 -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) 2428 | FrameTySig LFrame (LHsSigWcType GhcPs) 2429 -- ^ Type signature: x :: ty 2430 | FramePar (SrcSpan, SrcSpan) LFrame 2431 -- ^ Parentheses 2432 | FrameIf LFrame LFrame LFrame 2433 -- ^ If-expression: if p then x else y 2434 | FrameCase LFrame [LFrameMatch] 2435 -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } 2436 | FrameDo (HsStmtContext Name) [LFrameStmt] 2437 -- ^ Do-expression: do { s1; a <- s2; s3 } 2438 ... 2439 | FrameExpr (HsExpr GhcPs) -- unambiguously an expression 2440 | FramePat (HsPat GhcPs) -- unambiguously a pattern 2441 | FrameCommand (HsCmd GhcPs) -- unambiguously a command 2442 2443To determine which constructors 'Frame' needs to have, we take the union of 2444intersections between HsExpr, HsCmd, and HsPat. 2445 2446The intersection between HsPat and HsExpr: 2447 2448 HsPat = VarPat | TuplePat | SigPat | ParPat | ... 2449 HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ... 2450 ------------------------------------------------------------------- 2451 Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ... 2452 2453The intersection between HsCmd and HsExpr: 2454 2455 HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar 2456 HsExpr = HsIf | HsCase | HsDo | HsPar 2457 ------------------------------------------------ 2458 Frame = FrameIf | FrameCase | FrameDo | FramePar 2459 2460The intersection between HsCmd and HsPat: 2461 2462 HsPat = ParPat | ... 2463 HsCmd = HsCmdPar | ... 2464 ----------------------- 2465 Frame = FramePar | ... 2466 2467Take the union of each intersection and this yields the final 'Frame' data 2468type. The problem with this approach is that we end up duplicating a good 2469portion of hsSyn: 2470 2471 Frame for HsExpr, HsPat, HsCmd 2472 TupArgFrame for HsTupArg 2473 FrameMatch for Match 2474 FrameStmt for StmtLR 2475 FrameGRHS for GRHS 2476 FrameGRHSs for GRHSs 2477 ... 2478 2479Alternative VII, a product type 2480------------------------------- 2481We could avoid the intermediate representation of Alternative VI by parsing 2482into a product of interpretations directly: 2483 2484 -- See Note [Parser-Validator] 2485 type ExpCmdPat = ( PV (LHsExpr GhcPs) 2486 , PV (LHsCmd GhcPs) 2487 , PV (LHsPat GhcPs) ) 2488 2489This means that in positions where we do not know whether to produce 2490expression, a pattern, or a command, we instead produce a parser-validator for 2491each possible option. 2492 2493Then, as soon as we have parsed far enough to resolve the ambiguity, we pick 2494the appropriate component of the product, discarding the rest: 2495 2496 checkExpOf3 (e, _, _) = e -- interpret as an expression 2497 checkCmdOf3 (_, c, _) = c -- interpret as a command 2498 checkPatOf3 (_, _, p) = p -- interpret as a pattern 2499 2500We can easily define ambiguities between arbitrary subsets of interpretations. 2501For example, when we know ahead of type that only an expression or a command is 2502possible, but not a pattern, we can use a smaller type: 2503 2504 -- See Note [Parser-Validator] 2505 type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs)) 2506 2507 checkExpOf2 (e, _) = e -- interpret as an expression 2508 checkCmdOf2 (_, c) = c -- interpret as a command 2509 2510However, there is a slight problem with this approach, namely code duplication 2511in parser productions. Consider the 'alts' production used to parse case-of 2512alternatives: 2513 2514 alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } 2515 : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } 2516 | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } 2517 2518Under the new scheme, we have to completely duplicate its type signature and 2519each reduction rule: 2520 2521 alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression 2522 , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command 2523 ) } 2524 : alts1 2525 { ( checkExpOf2 $1 >>= \ $1 -> 2526 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) 2527 , checkCmdOf2 $1 >>= \ $1 -> 2528 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) 2529 ) } 2530 | ';' alts 2531 { ( checkExpOf2 $2 >>= \ $2 -> 2532 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) 2533 , checkCmdOf2 $2 >>= \ $2 -> 2534 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) 2535 ) } 2536 2537And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', 2538'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code! 2539 2540Alternative VIII, a function from a GADT 2541---------------------------------------- 2542We could avoid code duplication of the Alternative VII by representing the product 2543as a function from a GADT: 2544 2545 data ExpCmdG b where 2546 ExpG :: ExpCmdG HsExpr 2547 CmdG :: ExpCmdG HsCmd 2548 2549 type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) 2550 2551 checkExp :: ExpCmd -> PV (LHsExpr GhcPs) 2552 checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) 2553 checkExp f = f ExpG -- interpret as an expression 2554 checkCmd f = f CmdG -- interpret as a command 2555 2556Consider the 'alts' production used to parse case-of alternatives: 2557 2558 alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } 2559 : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } 2560 | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } 2561 2562We abstract over LHsExpr, and it becomes: 2563 2564 alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } 2565 : alts1 2566 { \tag -> $1 tag >>= \ $1 -> 2567 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } 2568 | ';' alts 2569 { \tag -> $2 tag >>= \ $2 -> 2570 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } 2571 2572Note that 'ExpCmdG' is a singleton type, the value is completely 2573determined by the type: 2574 2575 when (b~HsExpr), tag = ExpG 2576 when (b~HsCmd), tag = CmdG 2577 2578This is a clear indication that we can use a class to pass this value behind 2579the scenes: 2580 2581 class ExpCmdI b where expCmdG :: ExpCmdG b 2582 instance ExpCmdI HsExpr where expCmdG = ExpG 2583 instance ExpCmdI HsCmd where expCmdG = CmdG 2584 2585And now the 'alts' production is simplified, as we no longer need to 2586thread 'tag' explicitly: 2587 2588 alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } 2589 : alts1 { $1 >>= \ $1 -> 2590 return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } 2591 | ';' alts { $2 >>= \ $2 -> 2592 return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } 2593 2594This encoding works well enough, but introduces an extra GADT unlike the 2595tagless final encoding, and there's no need for this complexity. 2596 2597-} 2598 2599{- Note [PatBuilder] 2600~~~~~~~~~~~~~~~~~~~~ 2601Unlike HsExpr or HsCmd, the Pat type cannot accomodate all intermediate forms, 2602so we introduce the notion of a PatBuilder. 2603 2604Consider a pattern like this: 2605 2606 Con a b c 2607 2608We parse arguments to "Con" one at a time in the fexp aexp parser production, 2609building the result with mkHsAppPV, so the intermediate forms are: 2610 2611 1. Con 2612 2. Con a 2613 3. Con a b 2614 4. Con a b c 2615 2616In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like 2617this (pseudocode): 2618 2619 1. "Con" 2620 2. HsApp "Con" "a" 2621 3. HsApp (HsApp "Con" "a") "b" 2622 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" 2623 2624Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have 2625instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for 2626the intermediate forms. 2627 2628Worse yet, some intermediate forms are not valid patterns at all. For example: 2629 2630 Con !a !b c 2631 2632This is parsed as ((Con ! a) ! (b c)) with ! as an infix operator, and then 2633rearranged in 'splitBang'. But of course, neither (b c) nor (Con ! a) are valid 2634patterns, so we cannot represent them as Pat. 2635 2636We also need an intermediate representation to postpone disambiguation between 2637FunBind and PatBind. Consider: 2638 2639 a `Con` b = ... 2640 a `fun` b = ... 2641 2642How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We 2643learn this by inspecting an intermediate representation in 'isFunLhs' and 2644seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate 2645representation capable of representing both a FunBind and a PatBind, so Pat is 2646insufficient. 2647 2648PatBuilder is an extension of Pat that is capable of representing intermediate 2649parsing results for patterns and function bindings: 2650 2651 data PatBuilder p 2652 = PatBuilderPat (Pat p) 2653 | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) 2654 | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) 2655 ... 2656 2657It can represent any pattern via 'PatBuilderPat', but it also has a variety of 2658other constructors which were added by following a simple principle: we never 2659pattern match on the pattern stored inside 'PatBuilderPat'. 2660 2661For example, in 'splitBang' we need to match on space-separated and 2662bang-separated patterns, so these are represented with dedicated constructors 2663'PatBuilderApp' and 'PatBuilderOpApp'. In 'isFunLhs', we pattern match on 2664variables, so we have a dedicated 'PatBuilderVar' constructor for this despite 2665the existence of 'VarPat'. 2666-} 2667 2668--------------------------------------------------------------------------- 2669-- Miscellaneous utilities 2670 2671-- | Check if a fixity is valid. We support bypassing the usual bound checks 2672-- for some special operators. 2673checkPrecP 2674 :: Located (SourceText,Int) -- ^ precedence 2675 -> Located (OrdList (Located RdrName)) -- ^ operators 2676 -> P () 2677checkPrecP (dL->L l (_,i)) (dL->L _ ol) 2678 | 0 <= i, i <= maxPrecedence = pure () 2679 | all specialOp ol = pure () 2680 | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) 2681 where 2682 specialOp op = unLoc op `elem` [ eqTyCon_RDR 2683 , getRdrName funTyCon ] 2684 2685mkRecConstrOrUpdate 2686 :: LHsExpr GhcPs 2687 -> SrcSpan 2688 -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) 2689 -> PV (HsExpr GhcPs) 2690 2691mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) 2692 | isRdrDataCon c 2693 = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) 2694mkRecConstrOrUpdate exp _ (fs,dd) 2695 | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update") 2696 | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) 2697 2698mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs 2699mkRdrRecordUpd exp flds 2700 = RecordUpd { rupd_ext = noExtField 2701 , rupd_expr = exp 2702 , rupd_flds = flds } 2703 2704mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs 2705mkRdrRecordCon con flds 2706 = RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds } 2707 2708mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg 2709mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } 2710mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs 2711 , rec_dotdot = Just (cL s (length fs)) } 2712 2713mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs 2714mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) 2715 = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun 2716mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc nec)) _ _) 2717 = noExtCon nec 2718mk_rec_upd_field (HsRecField _ _ _) 2719 = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 2720 2721mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation 2722 -> InlinePragma 2723-- The (Maybe Activation) is because the user can omit 2724-- the activation spec (and usually does) 2725mkInlinePragma src (inl, match_info) mb_act 2726 = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes 2727 , inl_inline = inl 2728 , inl_sat = Nothing 2729 , inl_act = act 2730 , inl_rule = match_info } 2731 where 2732 act = case mb_act of 2733 Just act -> act 2734 Nothing -> -- No phase specified 2735 case inl of 2736 NoInline -> NeverActive 2737 _other -> AlwaysActive 2738 2739----------------------------------------------------------------------------- 2740-- utilities for foreign declarations 2741 2742-- construct a foreign import declaration 2743-- 2744mkImport :: Located CCallConv 2745 -> Located Safety 2746 -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) 2747 -> P (HsDecl GhcPs) 2748mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = 2749 case unLoc cconv of 2750 CCallConv -> mkCImport 2751 CApiConv -> mkCImport 2752 StdCallConv -> mkCImport 2753 PrimCallConv -> mkOtherImport 2754 JavaScriptCallConv -> mkOtherImport 2755 where 2756 -- Parse a C-like entity string of the following form: 2757 -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" 2758 -- If 'cid' is missing, the function name 'v' is used instead as symbol 2759 -- name (cf section 8.5.1 in Haskell 2010 report). 2760 mkCImport = do 2761 let e = unpackFS entity 2762 case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of 2763 Nothing -> addFatalError loc (text "Malformed entity string") 2764 Just importSpec -> returnSpec importSpec 2765 2766 -- currently, all the other import conventions only support a symbol name in 2767 -- the entity string. If it is missing, we use the function name instead. 2768 mkOtherImport = returnSpec importSpec 2769 where 2770 entity' = if nullFS entity 2771 then mkExtName (unLoc v) 2772 else entity 2773 funcTarget = CFunction (StaticTarget esrc entity' Nothing True) 2774 importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc) 2775 2776 returnSpec spec = return $ ForD noExtField $ ForeignImport 2777 { fd_i_ext = noExtField 2778 , fd_name = v 2779 , fd_sig_ty = ty 2780 , fd_fi = spec 2781 } 2782 2783 2784 2785-- the string "foo" is ambiguous: either a header or a C identifier. The 2786-- C identifier case comes first in the alternatives below, so we pick 2787-- that one. 2788parseCImport :: Located CCallConv -> Located Safety -> FastString -> String 2789 -> Located SourceText 2790 -> Maybe ForeignImport 2791parseCImport cconv safety nm str sourceText = 2792 listToMaybe $ map fst $ filter (null.snd) $ 2793 readP_to_S parse str 2794 where 2795 parse = do 2796 skipSpaces 2797 r <- choice [ 2798 string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), 2799 string "wrapper" >> return (mk Nothing CWrapper), 2800 do optional (token "static" >> skipSpaces) 2801 ((mk Nothing <$> cimp nm) +++ 2802 (do h <- munch1 hdr_char 2803 skipSpaces 2804 mk (Just (Header (SourceText h) (mkFastString h))) 2805 <$> cimp nm)) 2806 ] 2807 skipSpaces 2808 return r 2809 2810 token str = do _ <- string str 2811 toks <- look 2812 case toks of 2813 c : _ 2814 | id_char c -> pfail 2815 _ -> return () 2816 2817 mk h n = CImport cconv safety h n sourceText 2818 2819 hdr_char c = not (isSpace c) 2820 -- header files are filenames, which can contain 2821 -- pretty much any char (depending on the platform), 2822 -- so just accept any non-space character 2823 id_first_char c = isAlpha c || c == '_' 2824 id_char c = isAlphaNum c || c == '_' 2825 2826 cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) 2827 +++ (do isFun <- case unLoc cconv of 2828 CApiConv -> 2829 option True 2830 (do token "value" 2831 skipSpaces 2832 return False) 2833 _ -> return True 2834 cid' <- cid 2835 return (CFunction (StaticTarget NoSourceText cid' 2836 Nothing isFun))) 2837 where 2838 cid = return nm +++ 2839 (do c <- satisfy id_first_char 2840 cs <- many (satisfy id_char) 2841 return (mkFastString (c:cs))) 2842 2843 2844-- construct a foreign export declaration 2845-- 2846mkExport :: Located CCallConv 2847 -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) 2848 -> P (HsDecl GhcPs) 2849mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) 2850 = return $ ForD noExtField $ 2851 ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty 2852 , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) 2853 (cL le esrc) } 2854 where 2855 entity' | nullFS entity = mkExtName (unLoc v) 2856 | otherwise = entity 2857 2858-- Supplying the ext_name in a foreign decl is optional; if it 2859-- isn't there, the Haskell name is assumed. Note that no transformation 2860-- of the Haskell name is then performed, so if you foreign export (++), 2861-- it's external name will be "++". Too bad; it's important because we don't 2862-- want z-encoding (e.g. names with z's in them shouldn't be doubled) 2863-- 2864mkExtName :: RdrName -> CLabelString 2865mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) 2866 2867-------------------------------------------------------------------------------- 2868-- Help with module system imports/exports 2869 2870data ImpExpSubSpec = ImpExpAbs 2871 | ImpExpAll 2872 | ImpExpList [Located ImpExpQcSpec] 2873 | ImpExpAllWith [Located ImpExpQcSpec] 2874 2875data ImpExpQcSpec = ImpExpQcName (Located RdrName) 2876 | ImpExpQcType (Located RdrName) 2877 | ImpExpQcWildcard 2878 2879mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) 2880mkModuleImpExp (dL->L l specname) subs = 2881 case subs of 2882 ImpExpAbs 2883 | isVarNameSpace (rdrNameSpace name) 2884 -> return $ IEVar noExtField (cL l (ieNameFromSpec specname)) 2885 | otherwise -> IEThingAbs noExtField . cL l <$> nameT 2886 ImpExpAll -> IEThingAll noExtField . cL l <$> nameT 2887 ImpExpList xs -> 2888 (\newName -> IEThingWith noExtField (cL l newName) 2889 NoIEWildcard (wrapped xs) []) <$> nameT 2890 ImpExpAllWith xs -> 2891 do allowed <- getBit PatternSynonymsBit 2892 if allowed 2893 then 2894 let withs = map unLoc xs 2895 pos = maybe NoIEWildcard IEWildcard 2896 (findIndex isImpExpQcWildcard withs) 2897 ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs 2898 in (\newName 2899 -> IEThingWith noExtField (cL l newName) pos ies []) 2900 <$> nameT 2901 else addFatalError l 2902 (text "Illegal export form (use PatternSynonyms to enable)") 2903 where 2904 name = ieNameVal specname 2905 nameT = 2906 if isVarNameSpace (rdrNameSpace name) 2907 then addFatalError l 2908 (text "Expecting a type constructor but found a variable," 2909 <+> quotes (ppr name) <> text "." 2910 $$ if isSymOcc $ rdrNameOcc name 2911 then text "If" <+> quotes (ppr name) 2912 <+> text "is a type constructor" 2913 <+> text "then enable ExplicitNamespaces and use the 'type' keyword." 2914 else empty) 2915 else return $ ieNameFromSpec specname 2916 2917 ieNameVal (ImpExpQcName ln) = unLoc ln 2918 ieNameVal (ImpExpQcType ln) = unLoc ln 2919 ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" 2920 2921 ieNameFromSpec (ImpExpQcName ln) = IEName ln 2922 ieNameFromSpec (ImpExpQcType ln) = IEType ln 2923 ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" 2924 2925 wrapped = map (onHasSrcSpan ieNameFromSpec) 2926 2927mkTypeImpExp :: Located RdrName -- TcCls or Var name space 2928 -> P (Located RdrName) 2929mkTypeImpExp name = 2930 do allowed <- getBit ExplicitNamespacesBit 2931 unless allowed $ addError (getLoc name) $ 2932 text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" 2933 return (fmap (`setRdrNameSpace` tcClsName) name) 2934 2935checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) 2936checkImportSpec ie@(dL->L _ specs) = 2937 case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of 2938 [] -> return ie 2939 (l:_) -> importSpecError l 2940 where 2941 importSpecError l = 2942 addFatalError l 2943 (text "Illegal import form, this syntax can only be used to bundle" 2944 $+$ text "pattern synonyms with types in module exports.") 2945 2946-- In the correct order 2947mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) 2948mkImpExpSubSpec [] = return ([], ImpExpList []) 2949mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] = 2950 return ([], ImpExpAll) 2951mkImpExpSubSpec xs = 2952 if (any (isImpExpQcWildcard . unLoc) xs) 2953 then return $ ([], ImpExpAllWith xs) 2954 else return $ ([], ImpExpList xs) 2955 2956isImpExpQcWildcard :: ImpExpQcSpec -> Bool 2957isImpExpQcWildcard ImpExpQcWildcard = True 2958isImpExpQcWildcard _ = False 2959 2960----------------------------------------------------------------------------- 2961-- Warnings and failures 2962 2963warnPrepositiveQualifiedModule :: SrcSpan -> P () 2964warnPrepositiveQualifiedModule span = 2965 addWarning Opt_WarnPrepositiveQualifiedModule span msg 2966 where 2967 msg = text "Found" <+> quotes (text "qualified") 2968 <+> text "in prepositive position" 2969 $$ text "Suggested fix: place " <+> quotes (text "qualified") 2970 <+> text "after the module name instead." 2971 2972failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () 2973failOpNotEnabledImportQualifiedPost loc = addError loc msg 2974 where 2975 msg = text "Found" <+> quotes (text "qualified") 2976 <+> text "in postpositive position. " 2977 $$ text "To allow this, enable language extension 'ImportQualifiedPost'" 2978 2979failOpImportQualifiedTwice :: SrcSpan -> P () 2980failOpImportQualifiedTwice loc = addError loc msg 2981 where 2982 msg = text "Multiple occurences of 'qualified'" 2983 2984warnStarIsType :: SrcSpan -> P () 2985warnStarIsType span = addWarning Opt_WarnStarIsType span msg 2986 where 2987 msg = text "Using" <+> quotes (text "*") 2988 <+> text "(or its Unicode variant) to mean" 2989 <+> quotes (text "Data.Kind.Type") 2990 $$ text "relies on the StarIsType extension, which will become" 2991 $$ text "deprecated in the future." 2992 $$ text "Suggested fix: use" <+> quotes (text "Type") 2993 <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." 2994 2995warnStarBndr :: SrcSpan -> P () 2996warnStarBndr span = addWarning Opt_WarnStarBinder span msg 2997 where 2998 msg = text "Found binding occurrence of" <+> quotes (text "*") 2999 <+> text "yet StarIsType is enabled." 3000 $$ text "NB. To use (or export) this operator in" 3001 <+> text "modules with StarIsType," 3002 $$ text " including the definition module, you must qualify it." 3003 3004failOpFewArgs :: Located RdrName -> P a 3005failOpFewArgs (dL->L loc op) = 3006 do { star_is_type <- getBit StarIsTypeBit 3007 ; let msg = too_few $$ starInfo star_is_type op 3008 ; addFatalError loc msg } 3009 where 3010 too_few = text "Operator applied to too few arguments:" <+> ppr op 3011 3012failOpDocPrev :: SrcSpan -> P a 3013failOpDocPrev loc = addFatalError loc msg 3014 where 3015 msg = text "Unexpected documentation comment." 3016 3017failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a 3018failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg 3019 where 3020 msg = text "Strictness annotation applied to a compound type." $$ 3021 text "Did you mean to add parentheses?" $$ 3022 nest 2 (ppr str <> parens (ppr ty)) 3023 3024failOpStrictnessPosition :: Located SrcStrictness -> P a 3025failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg 3026 where 3027 msg = text "Strictness annotation cannot appear in this position." 3028 3029----------------------------------------------------------------------------- 3030-- Misc utils 3031 3032data PV_Context = 3033 PV_Context 3034 { pv_options :: ParserFlags 3035 , pv_hint :: SDoc -- See Note [Parser-Validator Hint] 3036 } 3037 3038data PV_Accum = 3039 PV_Accum 3040 { pv_messages :: DynFlags -> Messages 3041 , pv_annotations :: [(ApiAnnKey,[SrcSpan])] 3042 , pv_comment_q :: [Located AnnotationComment] 3043 , pv_annotations_comments :: [(SrcSpan,[Located AnnotationComment])] 3044 } 3045 3046data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum 3047 3048-- See Note [Parser-Validator] 3049newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } 3050 3051instance Functor PV where 3052 fmap = liftM 3053 3054instance Applicative PV where 3055 pure a = a `seq` PV (\_ acc -> PV_Ok acc a) 3056 (<*>) = ap 3057 3058instance Monad PV where 3059 m >>= f = PV $ \ctx acc -> 3060 case unPV m ctx acc of 3061 PV_Ok acc' a -> unPV (f a) ctx acc' 3062 PV_Failed acc' -> PV_Failed acc' 3063 3064runPV :: PV a -> P a 3065runPV = runPV_msg empty 3066 3067runPV_msg :: SDoc -> PV a -> P a 3068runPV_msg msg m = 3069 P $ \s -> 3070 let 3071 pv_ctx = PV_Context 3072 { pv_options = options s 3073 , pv_hint = msg } 3074 pv_acc = PV_Accum 3075 { pv_messages = messages s 3076 , pv_annotations = annotations s 3077 , pv_comment_q = comment_q s 3078 , pv_annotations_comments = annotations_comments s } 3079 mkPState acc' = 3080 s { messages = pv_messages acc' 3081 , annotations = pv_annotations acc' 3082 , comment_q = pv_comment_q acc' 3083 , annotations_comments = pv_annotations_comments acc' } 3084 in 3085 case unPV m pv_ctx pv_acc of 3086 PV_Ok acc' a -> POk (mkPState acc') a 3087 PV_Failed acc' -> PFailed (mkPState acc') 3088 3089localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a 3090localPV_msg f m = 3091 let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in 3092 PV (\ctx acc -> unPV m (modifyHint ctx) acc) 3093 3094instance MonadP PV where 3095 addError srcspan msg = 3096 PV $ \ctx acc@PV_Accum{pv_messages=m} -> 3097 let msg' = msg $$ pv_hint ctx in 3098 PV_Ok acc{pv_messages=appendError srcspan msg' m} () 3099 addWarning option srcspan warning = 3100 PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} -> 3101 PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} () 3102 addFatalError srcspan msg = 3103 addError srcspan msg >> PV (const PV_Failed) 3104 getBit ext = 3105 PV $ \ctx acc -> 3106 let b = ext `xtest` pExtsBitmap (pv_options ctx) in 3107 PV_Ok acc $! b 3108 addAnnotation l a v = 3109 PV $ \_ acc -> 3110 let 3111 (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc) 3112 annotations_comments' = new_ann_comments ++ pv_annotations_comments acc 3113 annotations' = ((l,a), [v]) : pv_annotations acc 3114 acc' = acc 3115 { pv_annotations = annotations' 3116 , pv_comment_q = comment_q' 3117 , pv_annotations_comments = annotations_comments' } 3118 in 3119 PV_Ok acc' () 3120 3121{- Note [Parser-Validator] 3122~~~~~~~~~~~~~~~~~~~~~~~~~~ 3123 3124When resolving ambiguities, we need to postpone failure to make a choice later. 3125For example, if we have ambiguity between some A and B, our parser could be 3126 3127 abParser :: P (Maybe A, Maybe B) 3128 3129This way we can represent four possible outcomes of parsing: 3130 3131 (Just a, Nothing) -- definitely A 3132 (Nothing, Just b) -- definitely B 3133 (Just a, Just b) -- either A or B 3134 (Nothing, Nothing) -- neither A nor B 3135 3136However, if we want to report informative parse errors, accumulate warnings, 3137and add API annotations, we are better off using 'P' instead of 'Maybe': 3138 3139 abParser :: P (P A, P B) 3140 3141So we have an outer layer of P that consumes the input and builds the inner 3142layer, which validates the input. 3143 3144For clarity, we introduce the notion of a parser-validator: a parser that does 3145not consume any input, but may fail or use other effects. Thus we have: 3146 3147 abParser :: P (PV A, PV B) 3148 3149-} 3150 3151{- Note [Parser-Validator Hint] 3152~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3153A PV computation is parametrized by a hint for error messages, which can be set 3154depending on validation context. We use this in checkPattern to fix #984. 3155 3156Consider this example, where the user has forgotten a 'do': 3157 3158 f _ = do 3159 x <- computation 3160 case () of 3161 _ -> 3162 result <- computation 3163 case () of () -> undefined 3164 3165GHC parses it as follows: 3166 3167 f _ = do 3168 x <- computation 3169 (case () of 3170 _ -> 3171 result) <- computation 3172 case () of () -> undefined 3173 3174Note that this fragment is parsed as a pattern: 3175 3176 case () of 3177 _ -> 3178 result 3179 3180We attempt to detect such cases and add a hint to the error messages: 3181 3182 T984.hs:6:9: 3183 Parse error in pattern: case () of { _ -> result } 3184 Possibly caused by a missing 'do'? 3185 3186The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed 3187as the 'pv_hint' field 'PV_Context'. When validating in a context other than 3188'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has 3189no effect on the error messages. 3190 3191-} 3192 3193-- | Hint about bang patterns, assuming @BangPatterns@ is off. 3194hintBangPat :: SrcSpan -> PatBuilder GhcPs -> PV () 3195hintBangPat span e = do 3196 bang_on <- getBit BangPatBit 3197 unless bang_on $ 3198 addFatalError span 3199 (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) 3200 3201data SumOrTuple b 3202 = Sum ConTag Arity (Located b) 3203 | Tuple [Located (Maybe (Located b))] 3204 3205pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc 3206pprSumOrTuple boxity = \case 3207 Sum alt arity e -> 3208 parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) 3209 <+> parClose 3210 Tuple xs -> 3211 parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs) 3212 <> parClose 3213 where 3214 ppr_bars n = hsep (replicate n (Outputable.char '|')) 3215 (parOpen, parClose) = 3216 case boxity of 3217 Boxed -> (text "(", text ")") 3218 Unboxed -> (text "(#", text "#)") 3219 3220mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) 3221 3222-- Tuple 3223mkSumOrTupleExpr l boxity (Tuple es) = 3224 return $ cL l (ExplicitTuple noExtField (map toTupArg es) boxity) 3225 where 3226 toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs 3227 toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) 3228 3229-- Sum 3230mkSumOrTupleExpr l Unboxed (Sum alt arity e) = 3231 return $ cL l (ExplicitSum noExtField alt arity e) 3232mkSumOrTupleExpr l Boxed a@Sum{} = 3233 addFatalError l (hang (text "Boxed sums not supported:") 2 3234 (pprSumOrTuple Boxed a)) 3235 3236mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) 3237 3238-- Tuple 3239mkSumOrTuplePat l boxity (Tuple ps) = do 3240 ps' <- traverse toTupPat ps 3241 return $ cL l (PatBuilderPat (TuplePat noExtField ps' boxity)) 3242 where 3243 toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) 3244 -- Ignore the element location so that the error message refers to the 3245 -- entire tuple. See #19504 (and the discussion) for details. 3246 toTupPat (dL -> L _ p) = case p of 3247 Nothing -> addFatalError l (text "Tuple section in pattern context") 3248 Just p' -> checkLPat p' 3249 3250-- Sum 3251mkSumOrTuplePat l Unboxed (Sum alt arity p) = do 3252 p' <- checkLPat p 3253 return $ cL l (PatBuilderPat (SumPat noExtField p' alt arity)) 3254mkSumOrTuplePat l Boxed a@Sum{} = 3255 addFatalError l (hang (text "Boxed sums not supported:") 2 3256 (pprSumOrTuple Boxed a)) 3257 3258mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs 3259mkLHsOpTy x op y = 3260 let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y 3261 in cL loc (mkHsOpTy x op y) 3262 3263mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs 3264mkLHsDocTy t doc = 3265 let loc = getLoc t `combineSrcSpans` getLoc doc 3266 in cL loc (HsDocTy noExtField t doc) 3267 3268mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs 3269mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) 3270 3271----------------------------------------------------------------------------- 3272-- Token symbols 3273 3274starSym :: Bool -> String 3275starSym True = "★" 3276starSym False = "*" 3277 3278forallSym :: Bool -> String 3279forallSym True = "∀" 3280forallSym False = "forall" 3281