1{- 2(c) The University of Glasgow 2006 3(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 4 5 6This module converts Template Haskell syntax into Hs syntax 7-} 8 9{-# LANGUAGE DeriveFunctor #-} 10{-# LANGUAGE FlexibleContexts #-} 11{-# LANGUAGE ScopedTypeVariables #-} 12{-# LANGUAGE TypeFamilies #-} 13{-# LANGUAGE ViewPatterns #-} 14 15module GHC.ThToHs 16 ( convertToHsExpr 17 , convertToPat 18 , convertToHsDecls 19 , convertToHsType 20 , thRdrNameGuesses 21 ) 22where 23 24import GhcPrelude 25 26import GHC.Hs as Hs 27import PrelNames 28import RdrName 29import qualified Name 30import Module 31import RdrHsSyn 32import OccName 33import SrcLoc 34import Type 35import qualified Coercion ( Role(..) ) 36import TysWiredIn 37import BasicTypes as Hs 38import ForeignCall 39import Unique 40import ErrUtils 41import Bag 42import Lexeme 43import Util 44import FastString 45import Outputable 46import MonadUtils ( foldrM ) 47 48import qualified Data.ByteString as BS 49import Control.Monad( unless, ap ) 50 51import Data.Maybe( catMaybes, isNothing ) 52import Language.Haskell.TH as TH hiding (sigP) 53import Language.Haskell.TH.Syntax as TH 54import Foreign.ForeignPtr 55import Foreign.Ptr 56import System.IO.Unsafe 57 58------------------------------------------------------------------- 59-- The external interface 60 61convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] 62convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds)) 63 where 64 cvt_dec d = wrapMsg "declaration" d (cvtDec d) 65 66convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) 67convertToHsExpr origin loc e 68 = initCvt origin loc $ wrapMsg "expression" e $ cvtl e 69 70convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) 71convertToPat origin loc p 72 = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p 73 74convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) 75convertToHsType origin loc t 76 = initCvt origin loc $ wrapMsg "type" t $ cvtType t 77 78------------------------------------------------------------------- 79newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) } 80 deriving (Functor) 81 -- Push down the Origin (that is configurable by 82 -- -fenable-th-splice-warnings) and source location; 83 -- Can fail, with a single error message 84 85-- NB: If the conversion succeeds with (Right x), there should 86-- be no exception values hiding in x 87-- Reason: so a (head []) in TH code doesn't subsequently 88-- make GHC crash when it tries to walk the generated tree 89 90-- Use the loc everywhere, for lack of anything better 91-- In particular, we want it on binding locations, so that variables bound in 92-- the spliced-in declarations get a location that at least relates to the splice point 93 94instance Applicative CvtM where 95 pure x = CvtM $ \_ loc -> Right (loc,x) 96 (<*>) = ap 97 98instance Monad CvtM where 99 (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of 100 Left err -> Left err 101 Right (loc',v) -> unCvtM (k v) origin loc' 102 103initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a 104initCvt origin loc (CvtM m) = fmap snd (m origin loc) 105 106force :: a -> CvtM () 107force a = a `seq` return () 108 109failWith :: MsgDoc -> CvtM a 110failWith m = CvtM (\_ _ -> Left m) 111 112getOrigin :: CvtM Origin 113getOrigin = CvtM (\origin loc -> Right (loc,origin)) 114 115getL :: CvtM SrcSpan 116getL = CvtM (\_ loc -> Right (loc,loc)) 117 118setL :: SrcSpan -> CvtM () 119setL loc = CvtM (\_ _ -> Right (loc, ())) 120 121returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a 122returnL x = CvtM (\_ loc -> Right (loc, cL loc x)) 123 124returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a) 125returnJustL = fmap Just . returnL 126 127wrapParL :: HasSrcSpan a => 128 (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a) 129wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (cL loc x))) 130 131wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b 132-- E.g wrapMsg "declaration" dec thing 133wrapMsg what item (CvtM m) 134 = CvtM $ \origin loc -> case m origin loc of 135 Left err -> Left (err $$ getPprStyle msg) 136 Right v -> Right v 137 where 138 -- Show the item in pretty syntax normally, 139 -- but with all its constructors if you say -dppr-debug 140 msg sty = hang (text "When splicing a TH" <+> text what <> colon) 141 2 (if debugStyle sty 142 then text (show item) 143 else text (pprint item)) 144 145wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a 146wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of 147 Left err -> Left err 148 Right (loc',v) -> Right (loc',cL loc v) 149 150------------------------------------------------------------------- 151cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] 152cvtDecs = fmap catMaybes . mapM cvtDec 153 154cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs)) 155cvtDec (TH.ValD pat body ds) 156 | TH.VarP s <- pat 157 = do { s' <- vNameL s 158 ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) 159 ; th_origin <- getOrigin 160 ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] } 161 162 | otherwise 163 = do { pat' <- cvtPat pat 164 ; body' <- cvtGuard body 165 ; ds' <- cvtLocalDecs (text "a where clause") ds 166 ; returnJustL $ Hs.ValD noExtField $ 167 PatBind { pat_lhs = pat' 168 , pat_rhs = GRHSs noExtField body' (noLoc ds') 169 , pat_ext = noExtField 170 , pat_ticks = ([],[]) } } 171 172cvtDec (TH.FunD nm cls) 173 | null cls 174 = failWith (text "Function binding for" 175 <+> quotes (text (TH.pprint nm)) 176 <+> text "has no equations") 177 | otherwise 178 = do { nm' <- vNameL nm 179 ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls 180 ; th_origin <- getOrigin 181 ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' } 182 183cvtDec (TH.SigD nm typ) 184 = do { nm' <- vNameL nm 185 ; ty' <- cvtType typ 186 ; returnJustL $ Hs.SigD noExtField 187 (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) } 188 189cvtDec (TH.KiSigD nm ki) 190 = do { nm' <- tconNameL nm 191 ; ki' <- cvtType ki 192 ; let sig' = StandaloneKindSig noExtField nm' (mkLHsSigType ki') 193 ; returnJustL $ Hs.KindSigD noExtField sig' } 194 195cvtDec (TH.InfixD fx nm) 196 -- Fixity signatures are allowed for variables, constructors, and types 197 -- the renamer automatically looks for types during renaming, even when 198 -- the RdrName says it's a variable or a constructor. So, just assume 199 -- it's a variable or constructor and proceed. 200 = do { nm' <- vcNameL nm 201 ; returnJustL (Hs.SigD noExtField (FixSig noExtField 202 (FixitySig noExtField [nm'] (cvtFixity fx)))) } 203 204cvtDec (PragmaD prag) 205 = cvtPragmaD prag 206 207cvtDec (TySynD tc tvs rhs) 208 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs 209 ; rhs' <- cvtType rhs 210 ; returnJustL $ TyClD noExtField $ 211 SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs' 212 , tcdFixity = Prefix 213 , tcdRhs = rhs' } } 214 215cvtDec (DataD ctxt tc tvs ksig constrs derivs) 216 = do { let isGadtCon (GadtC _ _ _) = True 217 isGadtCon (RecGadtC _ _ _) = True 218 isGadtCon (ForallC _ _ c) = isGadtCon c 219 isGadtCon _ = False 220 isGadtDecl = all isGadtCon constrs 221 isH98Decl = all (not . isGadtCon) constrs 222 ; unless (isGadtDecl || isH98Decl) 223 (failWith (text "Cannot mix GADT constructors with Haskell 98" 224 <+> text "constructors")) 225 ; unless (isNothing ksig || isGadtDecl) 226 (failWith (text "Kind signatures are only allowed on GADTs")) 227 ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs 228 ; ksig' <- cvtKind `traverse` ksig 229 ; cons' <- mapM cvtConstr constrs 230 ; derivs' <- cvtDerivs derivs 231 ; let defn = HsDataDefn { dd_ext = noExtField 232 , dd_ND = DataType, dd_cType = Nothing 233 , dd_ctxt = ctxt' 234 , dd_kindSig = ksig' 235 , dd_cons = cons', dd_derivs = derivs' } 236 ; returnJustL $ TyClD noExtField $ 237 DataDecl { tcdDExt = noExtField 238 , tcdLName = tc', tcdTyVars = tvs' 239 , tcdFixity = Prefix 240 , tcdDataDefn = defn } } 241 242cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) 243 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs 244 ; ksig' <- cvtKind `traverse` ksig 245 ; con' <- cvtConstr constr 246 ; derivs' <- cvtDerivs derivs 247 ; let defn = HsDataDefn { dd_ext = noExtField 248 , dd_ND = NewType, dd_cType = Nothing 249 , dd_ctxt = ctxt' 250 , dd_kindSig = ksig' 251 , dd_cons = [con'] 252 , dd_derivs = derivs' } 253 ; returnJustL $ TyClD noExtField $ 254 DataDecl { tcdDExt = noExtField 255 , tcdLName = tc', tcdTyVars = tvs' 256 , tcdFixity = Prefix 257 , tcdDataDefn = defn } } 258 259cvtDec (ClassD ctxt cl tvs fds decs) 260 = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs 261 ; fds' <- mapM cvt_fundep fds 262 ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs 263 ; unless (null adts') 264 (failWith $ (text "Default data instance declarations" 265 <+> text "are not allowed:") 266 $$ (Outputable.ppr adts')) 267 ; returnJustL $ TyClD noExtField $ 268 ClassDecl { tcdCExt = noExtField 269 , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' 270 , tcdFixity = Prefix 271 , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' 272 , tcdMeths = binds' 273 , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] } 274 -- no docs in TH ^^ 275 } 276 277cvtDec (InstanceD o ctxt ty decs) 278 = do { let doc = text "an instance declaration" 279 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs 280 ; unless (null fams') (failWith (mkBadDecMsg doc fams')) 281 ; ctxt' <- cvtContext funPrec ctxt 282 ; (dL->L loc ty') <- cvtType ty 283 ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty' 284 ; returnJustL $ InstD noExtField $ ClsInstD noExtField $ 285 ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty' 286 , cid_binds = binds' 287 , cid_sigs = Hs.mkClassOpSigs sigs' 288 , cid_tyfam_insts = ats', cid_datafam_insts = adts' 289 , cid_overlap_mode = fmap (cL loc . overlap) o } } 290 where 291 overlap pragma = 292 case pragma of 293 TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS") 294 TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE") 295 TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING") 296 TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT") 297 298 299 300 301cvtDec (ForeignD ford) 302 = do { ford' <- cvtForD ford 303 ; returnJustL $ ForD noExtField ford' } 304 305cvtDec (DataFamilyD tc tvs kind) 306 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs 307 ; result <- cvtMaybeKindToFamilyResultSig kind 308 ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ 309 FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing } 310 311cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) 312 = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys 313 ; ksig' <- cvtKind `traverse` ksig 314 ; cons' <- mapM cvtConstr constrs 315 ; derivs' <- cvtDerivs derivs 316 ; let defn = HsDataDefn { dd_ext = noExtField 317 , dd_ND = DataType, dd_cType = Nothing 318 , dd_ctxt = ctxt' 319 , dd_kindSig = ksig' 320 , dd_cons = cons', dd_derivs = derivs' } 321 322 ; returnJustL $ InstD noExtField $ DataFamInstD 323 { dfid_ext = noExtField 324 , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ 325 FamEqn { feqn_ext = noExtField 326 , feqn_tycon = tc' 327 , feqn_bndrs = bndrs' 328 , feqn_pats = typats' 329 , feqn_rhs = defn 330 , feqn_fixity = Prefix } }}} 331 332cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) 333 = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys 334 ; ksig' <- cvtKind `traverse` ksig 335 ; con' <- cvtConstr constr 336 ; derivs' <- cvtDerivs derivs 337 ; let defn = HsDataDefn { dd_ext = noExtField 338 , dd_ND = NewType, dd_cType = Nothing 339 , dd_ctxt = ctxt' 340 , dd_kindSig = ksig' 341 , dd_cons = [con'], dd_derivs = derivs' } 342 ; returnJustL $ InstD noExtField $ DataFamInstD 343 { dfid_ext = noExtField 344 , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ 345 FamEqn { feqn_ext = noExtField 346 , feqn_tycon = tc' 347 , feqn_bndrs = bndrs' 348 , feqn_pats = typats' 349 , feqn_rhs = defn 350 , feqn_fixity = Prefix } }}} 351 352cvtDec (TySynInstD eqn) 353 = do { (dL->L _ eqn') <- cvtTySynEqn eqn 354 ; returnJustL $ InstD noExtField $ TyFamInstD 355 { tfid_ext = noExtField 356 , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } 357 358cvtDec (OpenTypeFamilyD head) 359 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head 360 ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ 361 FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity' 362 } 363 364cvtDec (ClosedTypeFamilyD head eqns) 365 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head 366 ; eqns' <- mapM cvtTySynEqn eqns 367 ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ 368 FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix 369 result' injectivity' } 370 371cvtDec (TH.RoleAnnotD tc roles) 372 = do { tc' <- tconNameL tc 373 ; let roles' = map (noLoc . cvtRole) roles 374 ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') } 375 376cvtDec (TH.StandaloneDerivD ds cxt ty) 377 = do { cxt' <- cvtContext funPrec cxt 378 ; ds' <- traverse cvtDerivStrategy ds 379 ; (dL->L loc ty') <- cvtType ty 380 ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty' 381 ; returnJustL $ DerivD noExtField $ 382 DerivDecl { deriv_ext =noExtField 383 , deriv_strategy = ds' 384 , deriv_type = mkLHsSigWcType inst_ty' 385 , deriv_overlap_mode = Nothing } } 386 387cvtDec (TH.DefaultSigD nm typ) 388 = do { nm' <- vNameL nm 389 ; ty' <- cvtType typ 390 ; returnJustL $ Hs.SigD noExtField 391 $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')} 392 393cvtDec (TH.PatSynD nm args dir pat) 394 = do { nm' <- cNameL nm 395 ; args' <- cvtArgs args 396 ; dir' <- cvtDir nm' dir 397 ; pat' <- cvtPat pat 398 ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $ 399 PSB noExtField nm' args' pat' dir' } 400 where 401 cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args 402 cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2 403 cvtArgs (TH.RecordPatSyn sels) 404 = do { sels' <- mapM vNameL sels 405 ; vars' <- mapM (vNameL . mkNameS . nameBase) sels 406 ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } 407 408 cvtDir _ Unidir = return Unidirectional 409 cvtDir _ ImplBidir = return ImplicitBidirectional 410 cvtDir n (ExplBidir cls) = 411 do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls 412 ; th_origin <- getOrigin 413 ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms } 414 415cvtDec (TH.PatSynSigD nm ty) 416 = do { nm' <- cNameL nm 417 ; ty' <- cvtPatSynSigTy ty 418 ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')} 419 420-- Implicit parameter bindings are handled in cvtLocalDecs and 421-- cvtImplicitParamBind. They are not allowed in any other scope, so 422-- reaching this case indicates an error. 423cvtDec (TH.ImplicitParamBindD _ _) 424 = failWith (text "Implicit parameter binding only allowed in let or where") 425 426---------------- 427cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) 428cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) 429 = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs 430 ; (head_ty, args) <- split_ty_app lhs 431 ; case head_ty of 432 ConT nm -> do { nm' <- tconNameL nm 433 ; rhs' <- cvtType rhs 434 ; let args' = map wrap_tyarg args 435 ; returnL $ mkHsImplicitBndrs 436 $ FamEqn { feqn_ext = noExtField 437 , feqn_tycon = nm' 438 , feqn_bndrs = mb_bndrs' 439 , feqn_pats = args' 440 , feqn_fixity = Prefix 441 , feqn_rhs = rhs' } } 442 InfixT t1 nm t2 -> do { nm' <- tconNameL nm 443 ; args' <- mapM cvtType [t1,t2] 444 ; rhs' <- cvtType rhs 445 ; returnL $ mkHsImplicitBndrs 446 $ FamEqn { feqn_ext = noExtField 447 , feqn_tycon = nm' 448 , feqn_bndrs = mb_bndrs' 449 , feqn_pats = 450 (map HsValArg args') ++ args 451 , feqn_fixity = Hs.Infix 452 , feqn_rhs = rhs' } } 453 _ -> failWith $ text "Invalid type family instance LHS:" 454 <+> text (show lhs) 455 } 456 457---------------- 458cvt_ci_decs :: MsgDoc -> [TH.Dec] 459 -> CvtM (LHsBinds GhcPs, 460 [LSig GhcPs], 461 [LFamilyDecl GhcPs], 462 [LTyFamInstDecl GhcPs], 463 [LDataFamInstDecl GhcPs]) 464-- Convert the declarations inside a class or instance decl 465-- ie signatures, bindings, and associated types 466cvt_ci_decs doc decs 467 = do { decs' <- cvtDecs decs 468 ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs' 469 ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs' 470 ; let (sigs', prob_binds') = partitionWith is_sig no_ats' 471 ; let (binds', prob_fams') = partitionWith is_bind prob_binds' 472 ; let (fams', bads) = partitionWith is_fam_decl prob_fams' 473 ; unless (null bads) (failWith (mkBadDecMsg doc bads)) 474 ; return (listToBag binds', sigs', fams', ats', adts') } 475 476---------------- 477cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] 478 -> CvtM ( LHsContext GhcPs 479 , Located RdrName 480 , LHsQTyVars GhcPs) 481cvt_tycl_hdr cxt tc tvs 482 = do { cxt' <- cvtContext funPrec cxt 483 ; tc' <- tconNameL tc 484 ; tvs' <- cvtTvs tvs 485 ; return (cxt', tc', tvs') 486 } 487 488cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type 489 -> CvtM ( LHsContext GhcPs 490 , Located RdrName 491 , Maybe [LHsTyVarBndr GhcPs] 492 , HsTyPats GhcPs) 493cvt_datainst_hdr cxt bndrs tys 494 = do { cxt' <- cvtContext funPrec cxt 495 ; bndrs' <- traverse (mapM cvt_tv) bndrs 496 ; (head_ty, args) <- split_ty_app tys 497 ; case head_ty of 498 ConT nm -> do { nm' <- tconNameL nm 499 ; let args' = map wrap_tyarg args 500 ; return (cxt', nm', bndrs', args') } 501 InfixT t1 nm t2 -> do { nm' <- tconNameL nm 502 ; args' <- mapM cvtType [t1,t2] 503 ; return (cxt', nm', bndrs', 504 ((map HsValArg args') ++ args)) } 505 _ -> failWith $ text "Invalid type instance header:" 506 <+> text (show tys) } 507 508---------------- 509cvt_tyfam_head :: TypeFamilyHead 510 -> CvtM ( Located RdrName 511 , LHsQTyVars GhcPs 512 , Hs.LFamilyResultSig GhcPs 513 , Maybe (Hs.LInjectivityAnn GhcPs)) 514 515cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) 516 = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars 517 ; result' <- cvtFamilyResultSig result 518 ; injectivity' <- traverse cvtInjectivityAnnotation injectivity 519 ; return (tc', tyvars', result', injectivity') } 520 521------------------------------------------------------------------- 522-- Partitioning declarations 523------------------------------------------------------------------- 524 525is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) 526is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d) 527is_fam_decl decl = Right decl 528 529is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) 530is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) 531 = Left (cL loc d) 532is_tyfam_inst decl 533 = Right decl 534 535is_datafam_inst :: LHsDecl GhcPs 536 -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) 537is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) 538 = Left (cL loc d) 539is_datafam_inst decl 540 = Right decl 541 542is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) 543is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig) 544is_sig decl = Right decl 545 546is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) 547is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind) 548is_bind decl = Right decl 549 550is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec 551is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) 552is_ip_bind decl = Right decl 553 554mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc 555mkBadDecMsg doc bads 556 = sep [ text "Illegal declaration(s) in" <+> doc <> colon 557 , nest 2 (vcat (map Outputable.ppr bads)) ] 558 559--------------------------------------------------- 560-- Data types 561--------------------------------------------------- 562 563cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) 564 565cvtConstr (NormalC c strtys) 566 = do { c' <- cNameL c 567 ; tys' <- mapM cvt_arg strtys 568 ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') } 569 570cvtConstr (RecC c varstrtys) 571 = do { c' <- cNameL c 572 ; args' <- mapM cvt_id_arg varstrtys 573 ; returnL $ mkConDeclH98 c' Nothing Nothing 574 (RecCon (noLoc args')) } 575 576cvtConstr (InfixC st1 c st2) 577 = do { c' <- cNameL c 578 ; st1' <- cvt_arg st1 579 ; st2' <- cvt_arg st2 580 ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') } 581 582cvtConstr (ForallC tvs ctxt con) 583 = do { tvs' <- cvtTvs tvs 584 ; ctxt' <- cvtContext funPrec ctxt 585 ; (dL->L _ con') <- cvtConstr con 586 ; returnL $ add_forall tvs' ctxt' con' } 587 where 588 add_cxt lcxt Nothing = Just lcxt 589 add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2)) 590 = Just (cL loc (cxt1 ++ cxt2)) 591 592 add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) 593 = con { con_forall = noLoc $ not (null all_tvs) 594 , con_qvars = mkHsQTvs all_tvs 595 , con_mb_cxt = add_cxt cxt' cxt } 596 where 597 all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars 598 599 add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) 600 = con { con_forall = noLoc $ not (null all_tvs) 601 , con_ex_tvs = all_tvs 602 , con_mb_cxt = add_cxt cxt' cxt } 603 where 604 all_tvs = hsQTvExplicit tvs' ++ ex_tvs 605 606 add_forall _ _ (XConDecl nec) = noExtCon nec 607 608cvtConstr (GadtC [] _strtys _ty) 609 = failWith (text "GadtC must have at least one constructor name") 610 611cvtConstr (GadtC c strtys ty) 612 = do { c' <- mapM cNameL c 613 ; args <- mapM cvt_arg strtys 614 ; (dL->L _ ty') <- cvtType ty 615 ; c_ty <- mk_arr_apps args ty' 616 ; returnL $ fst $ mkGadtDecl c' c_ty} 617 618cvtConstr (RecGadtC [] _varstrtys _ty) 619 = failWith (text "RecGadtC must have at least one constructor name") 620 621cvtConstr (RecGadtC c varstrtys ty) 622 = do { c' <- mapM cNameL c 623 ; ty' <- cvtType ty 624 ; rec_flds <- mapM cvt_id_arg varstrtys 625 ; let rec_ty = noLoc (HsFunTy noExtField 626 (noLoc $ HsRecTy noExtField rec_flds) ty') 627 ; returnL $ fst $ mkGadtDecl c' rec_ty } 628 629cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness 630cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack 631cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack 632cvtSrcUnpackedness SourceUnpack = SrcUnpack 633 634cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness 635cvtSrcStrictness NoSourceStrictness = NoSrcStrict 636cvtSrcStrictness SourceLazy = SrcLazy 637cvtSrcStrictness SourceStrict = SrcStrict 638 639cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs) 640cvt_arg (Bang su ss, ty) 641 = do { ty'' <- cvtType ty 642 ; let ty' = parenthesizeHsType appPrec ty'' 643 su' = cvtSrcUnpackedness su 644 ss' = cvtSrcStrictness ss 645 ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' } 646 647cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) 648cvt_id_arg (i, str, ty) 649 = do { (dL->L li i') <- vNameL i 650 ; ty' <- cvt_arg (str,ty) 651 ; return $ noLoc (ConDeclField 652 { cd_fld_ext = noExtField 653 , cd_fld_names 654 = [cL li $ FieldOcc noExtField (cL li i')] 655 , cd_fld_type = ty' 656 , cd_fld_doc = Nothing}) } 657 658cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) 659cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs 660 ; returnL cs' } 661 662cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs) 663cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs 664 ; ys' <- mapM tNameL ys 665 ; returnL (xs', ys') } 666 667 668------------------------------------------ 669-- Foreign declarations 670------------------------------------------ 671 672cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) 673cvtForD (ImportF callconv safety from nm ty) 674 -- the prim and javascript calling conventions do not support headers 675 -- and are inserted verbatim, analogous to mkImport in RdrHsSyn 676 | callconv == TH.Prim || callconv == TH.JavaScript 677 = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing 678 (CFunction (StaticTarget (SourceText from) 679 (mkFastString from) Nothing 680 True)) 681 (noLoc $ quotedSourceText from)) 682 | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') 683 (mkFastString (TH.nameBase nm)) 684 from (noLoc $ quotedSourceText from) 685 = mk_imp impspec 686 | otherwise 687 = failWith $ text (show from) <+> text "is not a valid ccall impent" 688 where 689 mk_imp impspec 690 = do { nm' <- vNameL nm 691 ; ty' <- cvtType ty 692 ; return (ForeignImport { fd_i_ext = noExtField 693 , fd_name = nm' 694 , fd_sig_ty = mkLHsSigType ty' 695 , fd_fi = impspec }) 696 } 697 safety' = case safety of 698 Unsafe -> PlayRisky 699 Safe -> PlaySafe 700 Interruptible -> PlayInterruptible 701 702cvtForD (ExportF callconv as nm ty) 703 = do { nm' <- vNameL nm 704 ; ty' <- cvtType ty 705 ; let e = CExport (noLoc (CExportStatic (SourceText as) 706 (mkFastString as) 707 (cvt_conv callconv))) 708 (noLoc (SourceText as)) 709 ; return $ ForeignExport { fd_e_ext = noExtField 710 , fd_name = nm' 711 , fd_sig_ty = mkLHsSigType ty' 712 , fd_fe = e } } 713 714cvt_conv :: TH.Callconv -> CCallConv 715cvt_conv TH.CCall = CCallConv 716cvt_conv TH.StdCall = StdCallConv 717cvt_conv TH.CApi = CApiConv 718cvt_conv TH.Prim = PrimCallConv 719cvt_conv TH.JavaScript = JavaScriptCallConv 720 721------------------------------------------ 722-- Pragmas 723------------------------------------------ 724 725cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) 726cvtPragmaD (InlineP nm inline rm phases) 727 = do { nm' <- vNameL nm 728 ; let dflt = dfltActivation inline 729 ; let src TH.NoInline = "{-# NOINLINE" 730 src TH.Inline = "{-# INLINE" 731 src TH.Inlinable = "{-# INLINABLE" 732 ; let ip = InlinePragma { inl_src = SourceText $ src inline 733 , inl_inline = cvtInline inline 734 , inl_rule = cvtRuleMatch rm 735 , inl_act = cvtPhases phases dflt 736 , inl_sat = Nothing } 737 ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip } 738 739cvtPragmaD (SpecialiseP nm ty inline phases) 740 = do { nm' <- vNameL nm 741 ; ty' <- cvtType ty 742 ; let src TH.NoInline = "{-# SPECIALISE NOINLINE" 743 src TH.Inline = "{-# SPECIALISE INLINE" 744 src TH.Inlinable = "{-# SPECIALISE INLINE" 745 ; let (inline', dflt,srcText) = case inline of 746 Just inline1 -> (cvtInline inline1, dfltActivation inline1, 747 src inline1) 748 Nothing -> (NoUserInline, AlwaysActive, 749 "{-# SPECIALISE") 750 ; let ip = InlinePragma { inl_src = SourceText srcText 751 , inl_inline = inline' 752 , inl_rule = Hs.FunLike 753 , inl_act = cvtPhases phases dflt 754 , inl_sat = Nothing } 755 ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip } 756 757cvtPragmaD (SpecialiseInstP ty) 758 = do { ty' <- cvtType ty 759 ; returnJustL $ Hs.SigD noExtField $ 760 SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } 761 762cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) 763 = do { let nm' = mkFastString nm 764 ; let act = cvtPhases phases AlwaysActive 765 ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs 766 ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs 767 ; lhs' <- cvtl lhs 768 ; rhs' <- cvtl rhs 769 ; returnJustL $ Hs.RuleD noExtField 770 $ HsRules { rds_ext = noExtField 771 , rds_src = SourceText "{-# RULES" 772 , rds_rules = [noLoc $ 773 HsRule { rd_ext = noExtField 774 , rd_name = (noLoc (quotedSourceText nm,nm')) 775 , rd_act = act 776 , rd_tyvs = ty_bndrs' 777 , rd_tmvs = tm_bndrs' 778 , rd_lhs = lhs' 779 , rd_rhs = rhs' }] } 780 781 } 782 783cvtPragmaD (AnnP target exp) 784 = do { exp' <- cvtl exp 785 ; target' <- case target of 786 ModuleAnnotation -> return ModuleAnnProvenance 787 TypeAnnotation n -> do 788 n' <- tconName n 789 return (TypeAnnProvenance (noLoc n')) 790 ValueAnnotation n -> do 791 n' <- vcName n 792 return (ValueAnnProvenance (noLoc n')) 793 ; returnJustL $ Hs.AnnD noExtField 794 $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp' 795 } 796 797cvtPragmaD (LineP line file) 798 = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1)) 799 ; return Nothing 800 } 801cvtPragmaD (CompleteP cls mty) 802 = do { cls' <- noLoc <$> mapM cNameL cls 803 ; mty' <- traverse tconNameL mty 804 ; returnJustL $ Hs.SigD noExtField 805 $ CompleteMatchSig noExtField NoSourceText cls' mty' } 806 807dfltActivation :: TH.Inline -> Activation 808dfltActivation TH.NoInline = NeverActive 809dfltActivation _ = AlwaysActive 810 811cvtInline :: TH.Inline -> Hs.InlineSpec 812cvtInline TH.NoInline = Hs.NoInline 813cvtInline TH.Inline = Hs.Inline 814cvtInline TH.Inlinable = Hs.Inlinable 815 816cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo 817cvtRuleMatch TH.ConLike = Hs.ConLike 818cvtRuleMatch TH.FunLike = Hs.FunLike 819 820cvtPhases :: TH.Phases -> Activation -> Activation 821cvtPhases AllPhases dflt = dflt 822cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i 823cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i 824 825cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) 826cvtRuleBndr (RuleVar n) 827 = do { n' <- vNameL n 828 ; return $ noLoc $ Hs.RuleBndr noExtField n' } 829cvtRuleBndr (TypedRuleVar n ty) 830 = do { n' <- vNameL n 831 ; ty' <- cvtType ty 832 ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' } 833 834--------------------------------------------------- 835-- Declarations 836--------------------------------------------------- 837 838cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) 839cvtLocalDecs doc ds 840 = case partitionWith is_ip_bind ds of 841 ([], []) -> return (EmptyLocalBinds noExtField) 842 ([], _) -> do 843 ds' <- cvtDecs ds 844 let (binds, prob_sigs) = partitionWith is_bind ds' 845 let (sigs, bads) = partitionWith is_sig prob_sigs 846 unless (null bads) (failWith (mkBadDecMsg doc bads)) 847 return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs)) 848 (ip_binds, []) -> do 849 binds <- mapM (uncurry cvtImplicitParamBind) ip_binds 850 return (HsIPBinds noExtField (IPBinds noExtField binds)) 851 ((_:_), (_:_)) -> 852 failWith (text "Implicit parameters mixed with other bindings") 853 854cvtClause :: HsMatchContext RdrName 855 -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) 856cvtClause ctxt (Clause ps body wheres) 857 = do { ps' <- cvtPats ps 858 ; let pps = map (parenthesizePat appPrec) ps' 859 ; g' <- cvtGuard body 860 ; ds' <- cvtLocalDecs (text "a where clause") wheres 861 ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) } 862 863cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) 864cvtImplicitParamBind n e = do 865 n' <- wrapL (ipName n) 866 e' <- cvtl e 867 returnL (IPBind noExtField (Left n') e') 868 869------------------------------------------------------------------- 870-- Expressions 871------------------------------------------------------------------- 872 873cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) 874cvtl e = wrapL (cvt e) 875 where 876 cvt (VarE s) = do { s' <- vName s; return $ HsVar noExtField (noLoc s') } 877 cvt (ConE s) = do { s' <- cName s; return $ HsVar noExtField (noLoc s') } 878 cvt (LitE l) 879 | overloadedLit l = go cvtOverLit (HsOverLit noExtField) 880 (hsOverLitNeedsParens appPrec) 881 | otherwise = go cvtLit (HsLit noExtField) 882 (hsLitNeedsParens appPrec) 883 where 884 go :: (Lit -> CvtM (l GhcPs)) 885 -> (l GhcPs -> HsExpr GhcPs) 886 -> (l GhcPs -> Bool) 887 -> CvtM (HsExpr GhcPs) 888 go cvt_lit mk_expr is_compound_lit = do 889 l' <- cvt_lit l 890 let e' = mk_expr l' 891 return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e' 892 cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y 893 ; return $ HsApp noExtField (mkLHsPar x') 894 (mkLHsPar y')} 895 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y 896 ; return $ HsApp noExtField (mkLHsPar x') 897 (mkLHsPar y')} 898 cvt (AppTypeE e t) = do { e' <- cvtl e 899 ; t' <- cvtType t 900 ; let tp = parenthesizeHsType appPrec t' 901 ; return $ HsAppType noExtField e' 902 $ mkHsWildCardBndrs tp } 903 cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its 904 -- own expression to avoid pretty-printing 905 -- oddities that can result from zero-argument 906 -- lambda expressions. See #13856. 907 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e 908 ; let pats = map (parenthesizePat appPrec) ps' 909 ; th_origin <- getOrigin 910 ; return $ HsLam noExtField (mkMatchGroup th_origin 911 [mkSimpleMatch LambdaExpr 912 pats e'])} 913 cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms 914 ; th_origin <- getOrigin 915 ; return $ HsLamCase noExtField 916 (mkMatchGroup th_origin ms') 917 } 918 cvt (TupE es) = cvt_tup es Boxed 919 cvt (UnboxedTupE es) = cvt_tup es Unboxed 920 cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e 921 ; unboxedSumChecks alt arity 922 ; return $ ExplicitSum noExtField 923 alt arity e'} 924 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; 925 ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' } 926 cvt (MultiIfE alts) 927 | null alts = failWith (text "Multi-way if-expression with no alternatives") 928 | otherwise = do { alts' <- mapM cvtpair alts 929 ; return $ HsMultiIf noExtField alts' } 930 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds 931 ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'} 932 cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms 933 ; th_origin <- getOrigin 934 ; return $ HsCase noExtField e' 935 (mkMatchGroup th_origin ms') } 936 cvt (DoE ss) = cvtHsDo DoExpr ss 937 cvt (MDoE ss) = cvtHsDo MDoExpr ss 938 cvt (CompE ss) = cvtHsDo ListComp ss 939 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd 940 ; return $ ArithSeq noExtField Nothing dd' } 941 cvt (ListE xs) 942 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) 943 ; return (HsLit noExtField l') } 944 -- Note [Converting strings] 945 | otherwise = do { xs' <- mapM cvtl xs 946 ; return $ ExplicitList noExtField Nothing xs' 947 } 948 949 -- Infix expressions 950 cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $ 951 do { x' <- cvtl x 952 ; s' <- cvtl s 953 ; y' <- cvtl y 954 ; let px = parenthesizeHsExpr opPrec x' 955 py = parenthesizeHsExpr opPrec y' 956 ; wrapParL (HsPar noExtField) 957 $ OpApp noExtField px s' py } 958 -- Parenthesise both arguments and result, 959 -- to ensure this operator application does 960 -- does not get re-associated 961 -- See Note [Operator association] 962 cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $ 963 do { s' <- cvtl s; y' <- cvtl y 964 ; wrapParL (HsPar noExtField) $ 965 SectionR noExtField s' y' } 966 -- See Note [Sections in HsSyn] in GHC.Hs.Expr 967 cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $ 968 do { x' <- cvtl x; s' <- cvtl s 969 ; wrapParL (HsPar noExtField) $ 970 SectionL noExtField x' s' } 971 972 cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $ 973 do { s' <- cvtl s 974 ; return $ HsPar noExtField s' } 975 -- Can I indicate this is an infix thing? 976 -- Note [Dropping constructors] 977 978 cvt (UInfixE x s y) = ensureValidOpExp s $ 979 do { x' <- cvtl x 980 ; let x'' = case unLoc x' of 981 OpApp {} -> x' 982 _ -> mkLHsPar x' 983 ; cvtOpApp x'' s y } -- Note [Converting UInfix] 984 985 cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExtField e' } 986 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t 987 ; let pe = parenthesizeHsExpr sigPrec e' 988 ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') } 989 cvt (RecConE c flds) = do { c' <- cNameL c 990 ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds 991 ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } 992 cvt (RecUpdE e flds) = do { e' <- cvtl e 993 ; flds' 994 <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) 995 flds 996 ; return $ mkRdrRecordUpd e' flds' } 997 cvt (StaticE e) = fmap (HsStatic noExtField) $ cvtl e 998 cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is 999 -- important, because UnboundVarE may contain 1000 -- constructor names - see #14627. 1001 { s' <- vcName s 1002 ; return $ HsVar noExtField (noLoc s') } 1003 cvt (LabelE s) = do { return $ HsOverLabel noExtField Nothing (fsLit s) } 1004 cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } 1005 1006{- | #16895 Ensure an infix expression's operator is a variable/constructor. 1007Consider this example: 1008 1009 $(uInfixE [|1|] [|id id|] [|2|]) 1010 1011This infix expression is obviously ill-formed so we use this helper function 1012to reject such programs outright. 1013 1014The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp` 1015in Language.Haskell.TH.Ppr from the template-haskell library. 1016-} 1017ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a 1018ensureValidOpExp (VarE _n) m = m 1019ensureValidOpExp (ConE _n) m = m 1020ensureValidOpExp (UnboundVarE _n) m = m 1021ensureValidOpExp _e _m = 1022 failWith (text "Non-variable expression is not allowed in an infix expression") 1023 1024{- Note [Dropping constructors] 1025~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1026When we drop constructors from the input, we must insert parentheses around the 1027argument. For example: 1028 1029 UInfixE x * (AppE (InfixE (Just y) + Nothing) z) 1030 1031If we convert the InfixE expression to an operator section but don't insert 1032parentheses, the above expression would be reassociated to 1033 1034 OpApp (OpApp x * y) + z 1035 1036which we don't want. 1037-} 1038 1039cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) 1040 -> CvtM (LHsRecField' t (LHsExpr GhcPs)) 1041cvtFld f (v,e) 1042 = do { v' <- vNameL v; e' <- cvtl e 1043 ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v' 1044 , hsRecFieldArg = e' 1045 , hsRecPun = False}) } 1046 1047cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) 1048cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } 1049cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } 1050cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } 1051cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } 1052 1053cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs) 1054cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg 1055 cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e) 1056 ; es' <- mapM cvtl_maybe es 1057 ; return $ ExplicitTuple 1058 noExtField 1059 (map noLoc es') 1060 boxity } 1061 1062{- Note [Operator assocation] 1063We must be quite careful about adding parens: 1064 * Infix (UInfix ...) op arg Needs parens round the first arg 1065 * Infix (Infix ...) op arg Needs parens round the first arg 1066 * UInfix (UInfix ...) op arg No parens for first arg 1067 * UInfix (Infix ...) op arg Needs parens round first arg 1068 1069 1070Note [Converting UInfix] 1071~~~~~~~~~~~~~~~~~~~~~~~~ 1072When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust 1073the trees to reflect the fixities of the underlying operators: 1074 1075 UInfixE x * (UInfixE y + z) ---> (x * y) + z 1076 1077This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and 1078@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely 1079right-biased for types and left-biased for everything else. So we left-bias the 1080trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. 1081 1082Sample input: 1083 1084 UInfixE 1085 (UInfixE x op1 y) 1086 op2 1087 (UInfixE z op3 w) 1088 1089Sample output: 1090 1091 OpApp 1092 (OpApp 1093 (OpApp x op1 y) 1094 op2 1095 z) 1096 op3 1097 w 1098 1099The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this 1100biasing. 1101-} 1102 1103{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. 1104The produced tree of infix expressions will be left-biased, provided @x@ is. 1105 1106We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis 1107is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that 1108this holds for both branches (of @cvtOpApp@), provided we assume it holds for 1109the recursive calls to @cvtOpApp@. 1110 1111When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased 1112since we have already run @cvtl@ on it. 1113-} 1114cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs) 1115cvtOpApp x op1 (UInfixE y op2 z) 1116 = do { l <- wrapL $ cvtOpApp x op1 y 1117 ; cvtOpApp l op2 z } 1118cvtOpApp x op y 1119 = do { op' <- cvtl op 1120 ; y' <- cvtl y 1121 ; return (OpApp noExtField x op' y') } 1122 1123------------------------------------- 1124-- Do notation and statements 1125------------------------------------- 1126 1127cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs) 1128cvtHsDo do_or_lc stmts 1129 | null stmts = failWith (text "Empty stmt list in do-block") 1130 | otherwise 1131 = do { stmts' <- cvtStmts stmts 1132 ; let Just (stmts'', last') = snocView stmts' 1133 1134 ; last'' <- case last' of 1135 (dL->L loc (BodyStmt _ body _ _)) 1136 -> return (cL loc (mkLastStmt body)) 1137 _ -> failWith (bad_last last') 1138 1139 ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) } 1140 where 1141 bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon 1142 , nest 2 $ Outputable.ppr stmt 1143 , text "(It should be an expression.)" ] 1144 1145cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] 1146cvtStmts = mapM cvtStmt 1147 1148cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) 1149cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } 1150cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } 1151cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds 1152 ; returnL $ LetStmt noExtField (noLoc ds') } 1153cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss 1154 ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr } 1155 where 1156 cvt_one ds = do { ds' <- cvtStmts ds 1157 ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } 1158cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') } 1159 1160cvtMatch :: HsMatchContext RdrName 1161 -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) 1162cvtMatch ctxt (TH.Match p body decs) 1163 = do { p' <- cvtPat p 1164 ; let lp = case p' of 1165 (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875 1166 _ -> p' 1167 ; g' <- cvtGuard body 1168 ; decs' <- cvtLocalDecs (text "a where clause") decs 1169 ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) } 1170 1171cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] 1172cvtGuard (GuardedB pairs) = mapM cvtpair pairs 1173cvtGuard (NormalB e) = do { e' <- cvtl e 1174 ; g' <- returnL $ GRHS noExtField [] e'; return [g'] } 1175 1176cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) 1177cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs 1178 ; g' <- returnL $ mkBodyStmt ge' 1179 ; returnL $ GRHS noExtField [g'] rhs' } 1180cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs 1181 ; returnL $ GRHS noExtField gs' rhs' } 1182 1183cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) 1184cvtOverLit (IntegerL i) 1185 = do { force i; return $ mkHsIntegral (mkIntegralLit i) } 1186cvtOverLit (RationalL r) 1187 = do { force r; return $ mkHsFractional (mkFractionalLit r) } 1188cvtOverLit (StringL s) 1189 = do { let { s' = mkFastString s } 1190 ; force s' 1191 ; return $ mkHsIsString (quotedSourceText s) s' 1192 } 1193cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" 1194-- An Integer is like an (overloaded) '3' in a Haskell source program 1195-- Similarly 3.5 for fractionals 1196 1197{- Note [Converting strings] 1198~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1199If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to 1200a string literal for "xy". Of course, we might hope to get 1201(LitE (StringL "xy")), but not always, and allCharLs fails quickly 1202if it isn't a literal string 1203-} 1204 1205allCharLs :: [TH.Exp] -> Maybe String 1206-- Note [Converting strings] 1207-- NB: only fire up this setup for a non-empty list, else 1208-- there's a danger of returning "" for [] :: [Int]! 1209allCharLs xs 1210 = case xs of 1211 LitE (CharL c) : ys -> go [c] ys 1212 _ -> Nothing 1213 where 1214 go cs [] = Just (reverse cs) 1215 go cs (LitE (CharL c) : ys) = go (c:cs) ys 1216 go _ _ = Nothing 1217 1218cvtLit :: Lit -> CvtM (HsLit GhcPs) 1219cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } 1220cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } 1221cvtLit (FloatPrimL f) 1222 = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) } 1223cvtLit (DoublePrimL f) 1224 = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) } 1225cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } 1226cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } 1227cvtLit (StringL s) = do { let { s' = mkFastString s } 1228 ; force s' 1229 ; return $ HsString (quotedSourceText s) s' } 1230cvtLit (StringPrimL s) = do { let { s' = BS.pack s } 1231 ; force s' 1232 ; return $ HsStringPrim NoSourceText s' } 1233cvtLit (BytesPrimL (Bytes fptr off sz)) = do 1234 let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr -> 1235 BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz) 1236 force bs 1237 return $ HsStringPrim NoSourceText bs 1238cvtLit _ = panic "Convert.cvtLit: Unexpected literal" 1239 -- cvtLit should not be called on IntegerL, RationalL 1240 -- That precondition is established right here in 1241 -- Convert.hs, hence panic 1242 1243quotedSourceText :: String -> SourceText 1244quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" 1245 1246cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] 1247cvtPats pats = mapM cvtPat pats 1248 1249cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs) 1250cvtPat pat = wrapL (cvtp pat) 1251 1252cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) 1253cvtp (TH.LitP l) 1254 | overloadedLit l = do { l' <- cvtOverLit l 1255 ; return (mkNPat (noLoc l') Nothing) } 1256 -- Not right for negative patterns; 1257 -- need to think about that! 1258 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } 1259cvtp (TH.VarP s) = do { s' <- vName s 1260 ; return $ Hs.VarPat noExtField (noLoc s') } 1261cvtp (TupP ps) = do { ps' <- cvtPats ps 1262 ; return $ TuplePat noExtField ps' Boxed } 1263cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps 1264 ; return $ TuplePat noExtField ps' Unboxed } 1265cvtp (UnboxedSumP p alt arity) 1266 = do { p' <- cvtPat p 1267 ; unboxedSumChecks alt arity 1268 ; return $ SumPat noExtField p' alt arity } 1269cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps 1270 ; let pps = map (parenthesizePat appPrec) ps' 1271 ; return $ ConPatIn s' (PrefixCon pps) } 1272cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 1273 ; wrapParL (ParPat noExtField) $ 1274 ConPatIn s' $ 1275 InfixCon (parenthesizePat opPrec p1') 1276 (parenthesizePat opPrec p2') } 1277 -- See Note [Operator association] 1278cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] 1279cvtp (ParensP p) = do { p' <- cvtPat p; 1280 ; case unLoc p' of -- may be wrapped ConPatIn 1281 ParPat {} -> return $ unLoc p' 1282 _ -> return $ ParPat noExtField p' } 1283cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExtField p' } 1284cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExtField p' } 1285cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p 1286 ; return $ AsPat noExtField s' p' } 1287cvtp TH.WildP = return $ WildPat noExtField 1288cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs 1289 ; return $ ConPatIn c' 1290 $ Hs.RecCon (HsRecFields fs' Nothing) } 1291cvtp (ListP ps) = do { ps' <- cvtPats ps 1292 ; return 1293 $ ListPat noExtField ps'} 1294cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t 1295 ; return $ SigPat noExtField p' (mkLHsSigWcType t') } 1296cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p 1297 ; return $ ViewPat noExtField e' p'} 1298 1299cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) 1300cvtPatFld (s,p) 1301 = do { (dL->L ls s') <- vNameL s 1302 ; p' <- cvtPat p 1303 ; return (noLoc $ HsRecField { hsRecFieldLbl 1304 = cL ls $ mkFieldOcc (cL ls s') 1305 , hsRecFieldArg = p' 1306 , hsRecPun = False}) } 1307 1308{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. 1309The produced tree of infix patterns will be left-biased, provided @x@ is. 1310 1311See the @cvtOpApp@ documentation for how this function works. 1312-} 1313cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs) 1314cvtOpAppP x op1 (UInfixP y op2 z) 1315 = do { l <- wrapL $ cvtOpAppP x op1 y 1316 ; cvtOpAppP l op2 z } 1317cvtOpAppP x op y 1318 = do { op' <- cNameL op 1319 ; y' <- cvtPat y 1320 ; return (ConPatIn op' (InfixCon x y')) } 1321 1322----------------------------------------------------------- 1323-- Types and type variables 1324 1325cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) 1326cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } 1327 1328cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) 1329cvt_tv (TH.PlainTV nm) 1330 = do { nm' <- tNameL nm 1331 ; returnL $ UserTyVar noExtField nm' } 1332cvt_tv (TH.KindedTV nm ki) 1333 = do { nm' <- tNameL nm 1334 ; ki' <- cvtKind ki 1335 ; returnL $ KindedTyVar noExtField nm' ki' } 1336 1337cvtRole :: TH.Role -> Maybe Coercion.Role 1338cvtRole TH.NominalR = Just Coercion.Nominal 1339cvtRole TH.RepresentationalR = Just Coercion.Representational 1340cvtRole TH.PhantomR = Just Coercion.Phantom 1341cvtRole TH.InferR = Nothing 1342 1343cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs) 1344cvtContext p tys = do { preds' <- mapM cvtPred tys 1345 ; parenthesizeHsContext p <$> returnL preds' } 1346 1347cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) 1348cvtPred = cvtType 1349 1350cvtDerivClause :: TH.DerivClause 1351 -> CvtM (LHsDerivingClause GhcPs) 1352cvtDerivClause (TH.DerivClause ds ctxt) 1353 = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt 1354 ; ds' <- traverse cvtDerivStrategy ds 1355 ; returnL $ HsDerivingClause noExtField ds' ctxt' } 1356 1357cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) 1358cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy 1359cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy 1360cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy 1361cvtDerivStrategy (TH.ViaStrategy ty) = do 1362 ty' <- cvtType ty 1363 returnL $ Hs.ViaStrategy (mkLHsSigType ty') 1364 1365cvtType :: TH.Type -> CvtM (LHsType GhcPs) 1366cvtType = cvtTypeKind "type" 1367 1368cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) 1369cvtTypeKind ty_str ty 1370 = do { (head_ty, tys') <- split_ty_app ty 1371 ; let m_normals = mapM extract_normal tys' 1372 where extract_normal (HsValArg ty) = Just ty 1373 extract_normal _ = Nothing 1374 1375 ; case head_ty of 1376 TupleT n 1377 | Just normals <- m_normals 1378 , normals `lengthIs` n -- Saturated 1379 -> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals) 1380 | otherwise 1381 -> mk_apps 1382 (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) 1383 tys' 1384 UnboxedTupleT n 1385 | Just normals <- m_normals 1386 , normals `lengthIs` n -- Saturated 1387 -> returnL (HsTupleTy noExtField HsUnboxedTuple normals) 1388 | otherwise 1389 -> mk_apps 1390 (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) 1391 tys' 1392 UnboxedSumT n 1393 | n < 2 1394 -> failWith $ 1395 vcat [ text "Illegal sum arity:" <+> text (show n) 1396 , nest 2 $ 1397 text "Sums must have an arity of at least 2" ] 1398 | Just normals <- m_normals 1399 , normals `lengthIs` n -- Saturated 1400 -> returnL (HsSumTy noExtField normals) 1401 | otherwise 1402 -> mk_apps 1403 (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n)))) 1404 tys' 1405 ArrowT 1406 | Just normals <- m_normals 1407 , [x',y'] <- normals -> do 1408 x'' <- case unLoc x' of 1409 HsFunTy{} -> returnL (HsParTy noExtField x') 1410 HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646 1411 HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324 1412 _ -> return $ 1413 parenthesizeHsType sigPrec x' 1414 let y'' = parenthesizeHsType sigPrec y' 1415 returnL (HsFunTy noExtField x'' y'') 1416 | otherwise 1417 -> mk_apps 1418 (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon))) 1419 tys' 1420 ListT 1421 | Just normals <- m_normals 1422 , [x'] <- normals -> do 1423 returnL (HsListTy noExtField x') 1424 | otherwise 1425 -> mk_apps 1426 (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon))) 1427 tys' 1428 1429 VarT nm -> do { nm' <- tNameL nm 1430 ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' } 1431 ConT nm -> do { nm' <- tconName nm 1432 ; let prom = name_promotedness nm' 1433 ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'} 1434 1435 ForallT tvs cxt ty 1436 | null tys' 1437 -> do { tvs' <- cvtTvs tvs 1438 ; cxt' <- cvtContext funPrec cxt 1439 ; ty' <- cvtType ty 1440 ; loc <- getL 1441 ; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty 1442 rho_ty = mkHsQualTy cxt loc cxt' ty' 1443 1444 ; return hs_ty } 1445 1446 ForallVisT tvs ty 1447 | null tys' 1448 -> do { tvs' <- cvtTvs tvs 1449 ; ty' <- cvtType ty 1450 ; loc <- getL 1451 ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' } 1452 1453 SigT ty ki 1454 -> do { ty' <- cvtType ty 1455 ; ki' <- cvtKind ki 1456 ; mk_apps (HsKindSig noExtField ty' ki') tys' 1457 } 1458 1459 LitT lit 1460 -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys' 1461 1462 WildCardT 1463 -> mk_apps mkAnonWildCardTy tys' 1464 1465 InfixT t1 s t2 1466 -> do { s' <- tconName s 1467 ; t1' <- cvtType t1 1468 ; t2' <- cvtType t2 1469 ; let prom = name_promotedness s' 1470 ; mk_apps 1471 (HsTyVar noExtField prom (noLoc s')) 1472 ([HsValArg t1', HsValArg t2'] ++ tys') 1473 } 1474 1475 UInfixT t1 s t2 1476 -> do { t2' <- cvtType t2 1477 ; t <- cvtOpAppT t1 s t2' 1478 ; mk_apps (unLoc t) tys' 1479 } -- Note [Converting UInfix] 1480 1481 ParensT t 1482 -> do { t' <- cvtType t 1483 ; mk_apps (HsParTy noExtField t') tys' 1484 } 1485 1486 PromotedT nm -> do { nm' <- cName nm 1487 ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm')) 1488 tys' } 1489 -- Promoted data constructor; hence cName 1490 1491 PromotedTupleT n 1492 | Just normals <- m_normals 1493 , normals `lengthIs` n -- Saturated 1494 -> returnL (HsExplicitTupleTy noExtField normals) 1495 | otherwise 1496 -> mk_apps 1497 (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n)))) 1498 tys' 1499 1500 PromotedNilT 1501 -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys' 1502 1503 PromotedConsT -- See Note [Representing concrete syntax in types] 1504 -- in Language.Haskell.TH.Syntax 1505 | Just normals <- m_normals 1506 , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals 1507 -> do 1508 returnL (HsExplicitListTy noExtField ip (ty1:tys2)) 1509 | otherwise 1510 -> mk_apps 1511 (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon))) 1512 tys' 1513 1514 StarT 1515 -> mk_apps 1516 (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) 1517 tys' 1518 1519 ConstraintT 1520 -> mk_apps 1521 (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon))) 1522 tys' 1523 1524 EqualityT 1525 | Just normals <- m_normals 1526 , [x',y'] <- normals -> 1527 let px = parenthesizeHsType opPrec x' 1528 py = parenthesizeHsType opPrec y' 1529 in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py) 1530 -- The long-term goal is to remove the above case entirely and 1531 -- subsume it under the case for InfixT. See #15815, comment:6, 1532 -- for more details. 1533 1534 | otherwise -> 1535 mk_apps (HsTyVar noExtField NotPromoted 1536 (noLoc eqTyCon_RDR)) tys' 1537 ImplicitParamT n t 1538 -> do { n' <- wrapL $ ipName n 1539 ; t' <- cvtType t 1540 ; returnL (HsIParamTy noExtField n' t') 1541 } 1542 1543 _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) 1544 } 1545 1546-- ConT/InfixT can contain both data constructor (i.e., promoted) names and 1547-- other (i.e, unpromoted) names, as opposed to PromotedT, which can only 1548-- contain data constructor names. See #15572/#17394. We use this function to 1549-- determine whether to mark a name as promoted/unpromoted when dealing with 1550-- ConT/InfixT. 1551name_promotedness :: RdrName -> Hs.PromotionFlag 1552name_promotedness nm 1553 | isRdrDataCon nm = IsPromoted 1554 | otherwise = NotPromoted 1555 1556-- | Constructs an application of a type to arguments passed in a list. 1557mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) 1558mk_apps head_ty type_args = do 1559 head_ty' <- returnL head_ty 1560 -- We must parenthesize the function type in case of an explicit 1561 -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there 1562 -- _must_ be parentheses around `Maybe :: Type -> Type`. 1563 let phead_ty :: LHsType GhcPs 1564 phead_ty = parenthesizeHsType sigPrec head_ty' 1565 1566 go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) 1567 go [] = pure head_ty' 1568 go (arg:args) = 1569 case arg of 1570 HsValArg ty -> do p_ty <- add_parens ty 1571 mk_apps (HsAppTy noExtField phead_ty p_ty) args 1572 HsTypeArg l ki -> do p_ki <- add_parens ki 1573 mk_apps (HsAppKindTy l phead_ty p_ki) args 1574 HsArgPar _ -> mk_apps (HsParTy noExtField phead_ty) args 1575 1576 go type_args 1577 where 1578 -- See Note [Adding parens for splices] 1579 add_parens lt@(dL->L _ t) 1580 | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) 1581 | otherwise = return lt 1582 1583wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs 1584wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty 1585wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki 1586wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized 1587 1588-- --------------------------------------------------------------------- 1589-- Note [Adding parens for splices] 1590{- 1591The hsSyn representation of parsed source explicitly contains all the original 1592parens, as written in the source. 1593 1594When a Template Haskell (TH) splice is evaluated, the original splice is first 1595renamed and type checked and then finally converted to core in DsMeta. This core 1596is then run in the TH engine, and the result comes back as a TH AST. 1597 1598In the process, all parens are stripped out, as they are not needed. 1599 1600This Convert module then converts the TH AST back to hsSyn AST. 1601 1602In order to pretty-print this hsSyn AST, parens need to be adde back at certain 1603points so that the code is readable with its original meaning. 1604 1605So scattered through Convert.hs are various points where parens are added. 1606 1607See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289 1608-} 1609-- --------------------------------------------------------------------- 1610 1611-- | Constructs an arrow type with a specified return type 1612mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) 1613mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL 1614 where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) 1615 go arg ret_ty = do { ret_ty_l <- returnL ret_ty 1616 ; return (HsFunTy noExtField arg ret_ty_l) } 1617 1618split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) 1619split_ty_app ty = go ty [] 1620 where 1621 go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') } 1622 go (AppKindT ty ki) as' = do { ki' <- cvtKind ki 1623 ; go ty (HsTypeArg noSrcSpan ki':as') } 1624 go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } 1625 go f as = return (f,as) 1626 1627cvtTyLit :: TH.TyLit -> HsTyLit 1628cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i 1629cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) 1630 1631{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator 1632application @x `op` y@. The produced tree of infix types will be right-biased, 1633provided @y@ is. 1634 1635See the @cvtOpApp@ documentation for how this function works. 1636-} 1637cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs) 1638cvtOpAppT (UInfixT x op2 y) op1 z 1639 = do { l <- cvtOpAppT y op1 z 1640 ; cvtOpAppT x op2 l } 1641cvtOpAppT x op y 1642 = do { op' <- tconNameL op 1643 ; x' <- cvtType x 1644 ; returnL (mkHsOpTy x' op' y) } 1645 1646cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) 1647cvtKind = cvtTypeKind "kind" 1648 1649-- | Convert Maybe Kind to a type family result signature. Used with data 1650-- families where naming of the result is not possible (thus only kind or no 1651-- signature is possible). 1652cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind 1653 -> CvtM (LFamilyResultSig GhcPs) 1654cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExtField) 1655cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki 1656 ; returnL (Hs.KindSig noExtField ki') } 1657 1658-- | Convert type family result signature. Used with both open and closed type 1659-- families. 1660cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs) 1661cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExtField) 1662cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki 1663 ; returnL (Hs.KindSig noExtField ki') } 1664cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr 1665 ; returnL (Hs.TyVarSig noExtField tv) } 1666 1667-- | Convert injectivity annotation of a type family. 1668cvtInjectivityAnnotation :: TH.InjectivityAnn 1669 -> CvtM (Hs.LInjectivityAnn GhcPs) 1670cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) 1671 = do { annLHS' <- tNameL annLHS 1672 ; annRHS' <- mapM tNameL annRHS 1673 ; returnL (Hs.InjectivityAnn annLHS' annRHS') } 1674 1675cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs) 1676-- pattern synonym types are of peculiar shapes, which is why we treat 1677-- them separately from regular types; 1678-- see Note [Pattern synonym type signatures and Template Haskell] 1679cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) 1680 | null exis, null provs = cvtType (ForallT univs reqs ty) 1681 | null univs, null reqs = do { l <- getL 1682 ; ty' <- cvtType (ForallT exis provs ty) 1683 ; return $ cL l (HsQualTy { hst_ctxt = cL l [] 1684 , hst_xqual = noExtField 1685 , hst_body = ty' }) } 1686 | null reqs = do { l <- getL 1687 ; univs' <- hsQTvExplicit <$> cvtTvs univs 1688 ; ty' <- cvtType (ForallT exis provs ty) 1689 ; let forTy = HsForAllTy 1690 { hst_fvf = ForallInvis 1691 , hst_bndrs = univs' 1692 , hst_xforall = noExtField 1693 , hst_body = cL l cxtTy } 1694 cxtTy = HsQualTy { hst_ctxt = cL l [] 1695 , hst_xqual = noExtField 1696 , hst_body = ty' } 1697 ; return $ cL l forTy } 1698 | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) 1699cvtPatSynSigTy ty = cvtType ty 1700 1701----------------------------------------------------------- 1702cvtFixity :: TH.Fixity -> Hs.Fixity 1703cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir) 1704 where 1705 cvt_dir TH.InfixL = Hs.InfixL 1706 cvt_dir TH.InfixR = Hs.InfixR 1707 cvt_dir TH.InfixN = Hs.InfixN 1708 1709----------------------------------------------------------- 1710 1711 1712----------------------------------------------------------- 1713-- some useful things 1714 1715overloadedLit :: Lit -> Bool 1716-- True for literals that Haskell treats as overloaded 1717overloadedLit (IntegerL _) = True 1718overloadedLit (RationalL _) = True 1719overloadedLit _ = False 1720 1721-- Checks that are performed when converting unboxed sum expressions and 1722-- patterns alike. 1723unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM () 1724unboxedSumChecks alt arity 1725 | alt > arity 1726 = failWith $ text "Sum alternative" <+> text (show alt) 1727 <+> text "exceeds its arity," <+> text (show arity) 1728 | alt <= 0 1729 = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt) 1730 , nest 2 $ text "Sum alternatives must start from 1" ] 1731 | arity < 2 1732 = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity) 1733 , nest 2 $ text "Sums must have an arity of at least 2" ] 1734 | otherwise 1735 = return () 1736 1737-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the 1738-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' 1739-- using the provided 'LHsQTyVars' and 'LHsType'. 1740mkHsForAllTy :: [TH.TyVarBndr] 1741 -- ^ The original Template Haskell type variable binders 1742 -> SrcSpan 1743 -- ^ The location of the returned 'LHsType' if it needs an 1744 -- explicit forall 1745 -> ForallVisFlag 1746 -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@) 1747 -- or invisible (e.g., @forall a.@) 1748 -> LHsQTyVars GhcPs 1749 -- ^ The converted type variable binders 1750 -> LHsType GhcPs 1751 -- ^ The converted rho type 1752 -> LHsType GhcPs 1753 -- ^ The complete type, quantified with a forall if necessary 1754mkHsForAllTy tvs loc fvf tvs' rho_ty 1755 | null tvs = rho_ty 1756 | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf 1757 , hst_bndrs = hsQTvExplicit tvs' 1758 , hst_xforall = noExtField 1759 , hst_body = rho_ty } 1760 1761-- | If passed an empty 'TH.Cxt', this simply returns the third argument 1762-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided 1763-- 'LHsContext' and 'LHsType'. 1764 1765-- It's important that we don't build an HsQualTy if the context is empty, 1766-- as the pretty-printer for HsType _always_ prints contexts, even if 1767-- they're empty. See #13183. 1768mkHsQualTy :: TH.Cxt 1769 -- ^ The original Template Haskell context 1770 -> SrcSpan 1771 -- ^ The location of the returned 'LHsType' if it needs an 1772 -- explicit context 1773 -> LHsContext GhcPs 1774 -- ^ The converted context 1775 -> LHsType GhcPs 1776 -- ^ The converted tau type 1777 -> LHsType GhcPs 1778 -- ^ The complete type, qualified with a context if necessary 1779mkHsQualTy ctxt loc ctxt' ty 1780 | null ctxt = ty 1781 | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField 1782 , hst_ctxt = ctxt' 1783 , hst_body = ty } 1784 1785-------------------------------------------------------------------- 1786-- Turning Name back into RdrName 1787-------------------------------------------------------------------- 1788 1789-- variable names 1790vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) 1791vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName 1792 1793-- Variable names 1794vNameL n = wrapL (vName n) 1795vName n = cvtName OccName.varName n 1796 1797-- Constructor function names; this is Haskell source, hence srcDataName 1798cNameL n = wrapL (cName n) 1799cName n = cvtName OccName.dataName n 1800 1801-- Variable *or* constructor names; check by looking at the first char 1802vcNameL n = wrapL (vcName n) 1803vcName n = if isVarName n then vName n else cName n 1804 1805-- Type variable names 1806tNameL n = wrapL (tName n) 1807tName n = cvtName OccName.tvName n 1808 1809-- Type Constructor names 1810tconNameL n = wrapL (tconName n) 1811tconName n = cvtName OccName.tcClsName n 1812 1813ipName :: String -> CvtM HsIPName 1814ipName n 1815 = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n)) 1816 ; return (HsIPName (fsLit n)) } 1817 1818cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName 1819cvtName ctxt_ns (TH.Name occ flavour) 1820 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) 1821 | otherwise 1822 = do { loc <- getL 1823 ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour 1824 ; force rdr_name 1825 ; return rdr_name } 1826 where 1827 occ_str = TH.occString occ 1828 1829okOcc :: OccName.NameSpace -> String -> Bool 1830okOcc ns str 1831 | OccName.isVarNameSpace ns = okVarOcc str 1832 | OccName.isDataConNameSpace ns = okConOcc str 1833 | otherwise = okTcOcc str 1834 1835-- Determine the name space of a name in a type 1836-- 1837isVarName :: TH.Name -> Bool 1838isVarName (TH.Name occ _) 1839 = case TH.occString occ of 1840 "" -> False 1841 (c:_) -> startsVarId c || startsVarSym c 1842 1843badOcc :: OccName.NameSpace -> String -> SDoc 1844badOcc ctxt_ns occ 1845 = text "Illegal" <+> pprNameSpace ctxt_ns 1846 <+> text "name:" <+> quotes (text occ) 1847 1848thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName 1849-- This turns a TH Name into a RdrName; used for both binders and occurrences 1850-- See Note [Binders in Template Haskell] 1851-- The passed-in name space tells what the context is expecting; 1852-- use it unless the TH name knows what name-space it comes 1853-- from, in which case use the latter 1854-- 1855-- We pass in a SrcSpan (gotten from the monad) because this function 1856-- is used for *binders* and if we make an Exact Name we want it 1857-- to have a binding site inside it. (cf #5434) 1858-- 1859-- ToDo: we may generate silly RdrNames, by passing a name space 1860-- that doesn't match the string, like VarName ":+", 1861-- which will give confusing error messages later 1862-- 1863-- The strict applications ensure that any buried exceptions get forced 1864thRdrName loc ctxt_ns th_occ th_name 1865 = case th_name of 1866 TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod 1867 TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ 1868 TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc) 1869 TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc) 1870 TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name 1871 | otherwise -> mkRdrUnqual $! occ 1872 -- We check for built-in syntax here, because the TH 1873 -- user might have written a (NameS "(,,)"), for example 1874 where 1875 occ :: OccName.OccName 1876 occ = mk_occ ctxt_ns th_occ 1877 1878-- Return an unqualified exact RdrName if we're dealing with built-in syntax. 1879-- See #13776. 1880thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName 1881thOrigRdrName occ th_ns pkg mod = 1882 let occ' = mk_occ (mk_ghc_ns th_ns) occ 1883 in case isBuiltInOcc_maybe occ' of 1884 Just name -> nameRdrName name 1885 Nothing -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ' 1886 1887thRdrNameGuesses :: TH.Name -> [RdrName] 1888thRdrNameGuesses (TH.Name occ flavour) 1889 -- This special case for NameG ensures that we don't generate duplicates in the output list 1890 | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod] 1891 | otherwise = [ thRdrName noSrcSpan gns occ_str flavour 1892 | gns <- guessed_nss] 1893 where 1894 -- guessed_ns are the name spaces guessed from looking at the TH name 1895 guessed_nss 1896 | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] 1897 | otherwise = [OccName.varName, OccName.tvName] 1898 occ_str = TH.occString occ 1899 1900-- The packing and unpacking is rather turgid :-( 1901mk_occ :: OccName.NameSpace -> String -> OccName.OccName 1902mk_occ ns occ = OccName.mkOccName ns occ 1903 1904mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace 1905mk_ghc_ns TH.DataName = OccName.dataName 1906mk_ghc_ns TH.TcClsName = OccName.tcClsName 1907mk_ghc_ns TH.VarName = OccName.varName 1908 1909mk_mod :: TH.ModName -> ModuleName 1910mk_mod mod = mkModuleName (TH.modString mod) 1911 1912mk_pkg :: TH.PkgName -> UnitId 1913mk_pkg pkg = stringToUnitId (TH.pkgString pkg) 1914 1915mk_uniq :: Int -> Unique 1916mk_uniq u = mkUniqueGrimily u 1917 1918{- 1919Note [Binders in Template Haskell] 1920~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1921Consider this TH term construction: 1922 do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name 1923 ; x2 <- TH.newName "x" -- Builds a NameU 1924 ; x3 <- TH.newName "x" 1925 1926 ; let x = mkName "x" -- mkName :: String -> TH.Name 1927 -- Builds a NameS 1928 1929 ; return (LamE (..pattern [x1,x2]..) $ 1930 LamE (VarPat x3) $ 1931 ..tuple (x1,x2,x3,x)) } 1932 1933It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) 1934 1935a) We don't want to complain about "x" being bound twice in 1936 the pattern [x1,x2] 1937b) We don't want x3 to shadow the x1,x2 1938c) We *do* want 'x' (dynamically bound with mkName) to bind 1939 to the innermost binding of "x", namely x3. 1940d) When pretty printing, we want to print a unique with x1,x2 1941 etc, else they'll all print as "x" which isn't very helpful 1942 1943When we convert all this to HsSyn, the TH.Names are converted with 1944thRdrName. To achieve (b) we want the binders to be Exact RdrNames. 1945Achieving (a) is a bit awkward, because 1946 - We must check for duplicate and shadowed names on Names, 1947 not RdrNames, *after* renaming. 1948 See Note [Collect binders only after renaming] in GHC.Hs.Utils 1949 1950 - But to achieve (a) we must distinguish between the Exact 1951 RdrNames arising from TH and the Unqual RdrNames that would 1952 come from a user writing \[x,x] -> blah 1953 1954So in Convert.thRdrName we translate 1955 TH Name RdrName 1956 -------------------------------------------------------- 1957 NameU (arising from newName) --> Exact (Name{ System }) 1958 NameS (arising from mkName) --> Unqual 1959 1960Notice that the NameUs generate *System* Names. Then, when 1961figuring out shadowing and duplicates, we can filter out 1962System Names. 1963 1964This use of System Names fits with other uses of System Names, eg for 1965temporary variables "a". Since there are lots of things called "a" we 1966usually want to print the name with the unique, and that is indeed 1967the way System Names are printed. 1968 1969There's a small complication of course; see Note [Looking up Exact 1970RdrNames] in RnEnv. 1971-} 1972 1973{- 1974Note [Pattern synonym type signatures and Template Haskell] 1975~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1976 1977In general, the type signature of a pattern synonym 1978 1979 pattern P x1 x2 .. xn = <some-pattern> 1980 1981is of the form 1982 1983 forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t 1984 1985with the following parts: 1986 1987 1) the (possibly empty lists of) universally quantified type 1988 variables `univs` and required constraints `reqs` on them. 1989 2) the (possibly empty lists of) existentially quantified type 1990 variables `exis` and the provided constraints `provs` on them. 1991 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1, 1992 x2, .., xn, respectively 1993 4) the type `t` of <some-pattern>, mentioning only universals from `univs`. 1994 1995Due to the two forall quantifiers and constraint contexts (either of 1996which might be empty), pattern synonym type signatures are treated 1997specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and 1998`typecheck/TcSplice.hs`: 1999 2000 (a) When desugaring a pattern synonym from HsSyn to TH.Dec in 2001 `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.: 2002 2003 ForallT univs reqs (ForallT exis provs ty) 2004 (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) 2005 2006 (b) When converting pattern synonyms from TH.Dec to HsSyn in 2007 `hsSyn/Convert.hs`, we convert their TH type signatures back to an 2008 appropriate Haskell pattern synonym type of the form 2009 2010 forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t 2011 2012 where initial empty `univs` type variables or an empty `reqs` 2013 constraint context are represented *explicitly* as `() =>`. 2014 2015 (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always 2016 return its *full* type, i.e.: 2017 2018 ForallT univs reqs (ForallT exis provs ty) 2019 (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) 2020 2021The key point is to always represent a pattern synonym's *full* type 2022in cases (a) and (c) to make it clear which of the two forall 2023quantifiers and/or constraint contexts are specified, and which are 2024not. See GHC's user's guide on pattern synonyms for more information 2025about pattern synonym type signatures. 2026 2027-} 2028