From 5119296440e6846c553c72b8a93afc5ecfa576f0 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Wed, 11 Sep 2019 21:19:39 +0200 Subject: Module hierarchy: Hs (#13009) Add GHC.Hs module hierarchy replacing hsSyn. Metric Increase: haddock.compiler --- compiler/GHC/Hs.hs | 153 ++ compiler/GHC/Hs/Binds.hs | 1310 +++++++++ compiler/GHC/Hs/Decls.hs | 2417 +++++++++++++++++ compiler/GHC/Hs/Doc.hs | 152 ++ compiler/GHC/Hs/Dump.hs | 220 ++ compiler/GHC/Hs/Expr.hs | 2828 ++++++++++++++++++++ compiler/GHC/Hs/Expr.hs-boot | 51 + compiler/GHC/Hs/Extension.hs | 1168 ++++++++ compiler/GHC/Hs/ImpExp.hs | 366 +++ compiler/GHC/Hs/Instances.hs | 420 +++ compiler/GHC/Hs/Lit.hs | 314 +++ compiler/GHC/Hs/Pat.hs | 846 ++++++ compiler/GHC/Hs/Pat.hs-boot | 18 + compiler/GHC/Hs/PlaceHolder.hs | 70 + compiler/GHC/Hs/Types.hs | 1724 ++++++++++++ compiler/GHC/Hs/Utils.hs | 1416 ++++++++++ compiler/GHC/ThToHs.hs | 2015 ++++++++++++++ compiler/backpack/BkpSyn.hs | 2 +- compiler/basicTypes/BasicTypes.hs | 2 +- compiler/coreSyn/CoreSyn.hs | 6 +- compiler/coreSyn/MkCore.hs | 2 +- compiler/deSugar/Check.hs | 4 +- compiler/deSugar/Coverage.hs | 2 +- compiler/deSugar/Desugar.hs | 2 +- compiler/deSugar/DsArrows.hs | 12 +- compiler/deSugar/DsBinds.hs | 6 +- compiler/deSugar/DsExpr.hs | 2 +- compiler/deSugar/DsExpr.hs-boot | 4 +- compiler/deSugar/DsForeign.hs | 2 +- compiler/deSugar/DsGRHSs.hs | 2 +- compiler/deSugar/DsListComp.hs | 2 +- compiler/deSugar/DsMeta.hs | 2 +- compiler/deSugar/DsMonad.hs | 2 +- compiler/deSugar/DsUtils.hs | 4 +- compiler/deSugar/ExtractDocs.hs | 12 +- compiler/deSugar/Match.hs | 2 +- compiler/deSugar/Match.hs-boot | 4 +- compiler/deSugar/MatchCon.hs | 2 +- compiler/deSugar/MatchLit.hs | 2 +- compiler/ghc.cabal.in | 31 +- compiler/hieFile/HieAst.hs | 2 +- compiler/hsSyn/Convert.hs | 2010 -------------- compiler/hsSyn/HsBinds.hs | 1310 --------- compiler/hsSyn/HsDecls.hs | 2417 ----------------- compiler/hsSyn/HsDoc.hs | 152 -- compiler/hsSyn/HsDumpAst.hs | 220 -- compiler/hsSyn/HsExpr.hs | 2828 -------------------- compiler/hsSyn/HsExpr.hs-boot | 51 - compiler/hsSyn/HsExtension.hs | 1168 -------- compiler/hsSyn/HsImpExp.hs | 366 --- compiler/hsSyn/HsInstances.hs | 420 --- compiler/hsSyn/HsLit.hs | 314 --- compiler/hsSyn/HsPat.hs | 846 ------ compiler/hsSyn/HsPat.hs-boot | 18 - compiler/hsSyn/HsSyn.hs | 153 -- compiler/hsSyn/HsTypes.hs | 1724 ------------ compiler/hsSyn/HsUtils.hs | 1416 ---------- compiler/hsSyn/PlaceHolder.hs | 70 - compiler/iface/MkIface.hs | 2 +- compiler/main/GHC.hs | 4 +- compiler/main/GhcPlugins.hs | 2 +- compiler/main/HeaderInfo.hs | 2 +- compiler/main/Hooks.hs | 8 +- compiler/main/HscMain.hs | 4 +- compiler/main/HscStats.hs | 2 +- compiler/main/HscTypes.hs | 2 +- compiler/main/InteractiveEval.hs | 2 +- compiler/main/Plugins.hs | 2 +- compiler/parser/HaddockUtils.hs | 2 +- compiler/parser/Parser.y | 4 +- compiler/parser/RdrHsSyn.hs | 22 +- compiler/rename/RnBinds.hs | 4 +- compiler/rename/RnEnv.hs | 2 +- compiler/rename/RnExpr.hs | 4 +- compiler/rename/RnExpr.hs-boot | 2 +- compiler/rename/RnFixity.hs | 2 +- compiler/rename/RnHsDoc.hs | 2 +- compiler/rename/RnNames.hs | 4 +- compiler/rename/RnPat.hs | 6 +- compiler/rename/RnSource.hs | 6 +- compiler/rename/RnSplice.hs | 2 +- compiler/rename/RnSplice.hs-boot | 2 +- compiler/rename/RnTypes.hs | 6 +- compiler/rename/RnUtils.hs | 2 +- compiler/stgSyn/StgSyn.hs | 6 +- compiler/typecheck/Inst.hs | 4 +- compiler/typecheck/TcAnnotations.hs | 2 +- compiler/typecheck/TcArrows.hs | 4 +- compiler/typecheck/TcBackpack.hs | 2 +- compiler/typecheck/TcBinds.hs | 2 +- compiler/typecheck/TcCanonical.hs | 2 +- compiler/typecheck/TcClassDcl.hs | 2 +- compiler/typecheck/TcDefaults.hs | 2 +- compiler/typecheck/TcDeriv.hs | 2 +- compiler/typecheck/TcDerivUtils.hs | 2 +- compiler/typecheck/TcEnv.hs | 4 +- compiler/typecheck/TcErrors.hs | 4 +- compiler/typecheck/TcExpr.hs | 6 +- compiler/typecheck/TcExpr.hs-boot | 4 +- compiler/typecheck/TcForeign.hs | 2 +- compiler/typecheck/TcGenDeriv.hs | 2 +- compiler/typecheck/TcGenFunctor.hs | 2 +- compiler/typecheck/TcGenGenerics.hs | 2 +- compiler/typecheck/TcHoleErrors.hs | 2 +- compiler/typecheck/TcHoleFitTypes.hs | 2 +- compiler/typecheck/TcHsSyn.hs | 2 +- compiler/typecheck/TcHsType.hs | 14 +- compiler/typecheck/TcInstDcls.hs | 2 +- compiler/typecheck/TcInstDcls.hs-boot | 2 +- compiler/typecheck/TcMatches.hs | 6 +- compiler/typecheck/TcMatches.hs-boot | 4 +- compiler/typecheck/TcPat.hs | 2 +- compiler/typecheck/TcPatSyn.hs | 2 +- compiler/typecheck/TcPatSyn.hs-boot | 4 +- compiler/typecheck/TcRnDriver.hs | 4 +- compiler/typecheck/TcRnExports.hs | 2 +- compiler/typecheck/TcRnMonad.hs | 2 +- compiler/typecheck/TcRnTypes.hs | 2 +- compiler/typecheck/TcRules.hs | 2 +- compiler/typecheck/TcSigs.hs | 2 +- compiler/typecheck/TcSimplify.hs | 2 +- compiler/typecheck/TcSplice.hs | 6 +- compiler/typecheck/TcSplice.hs-boot | 6 +- compiler/typecheck/TcTyClsDecls.hs | 4 +- compiler/typecheck/TcTyDecls.hs | 2 +- compiler/typecheck/TcTypeable.hs | 2 +- compiler/typecheck/TcUnify.hs | 2 +- compiler/typecheck/TcUnify.hs-boot | 12 +- compiler/typecheck/TcValidity.hs | 2 +- compiler/types/TyCon.hs | 2 +- compiler/types/Type.hs | 6 +- docs/users_guide/extending_ghc.rst | 10 +- ghc/GHCi/UI.hs | 4 +- ghc/GHCi/UI/Monad.hs | 4 +- nofib | 2 +- .../tests/ghc-api/annotations/stringSource.hs | 2 +- testsuite/tests/ghc-api/annotations/t11430.hs | 2 +- testsuite/tests/package/all.T | 2 +- testsuite/tests/package/package05.hs | 6 +- testsuite/tests/package/package06.hs | 4 +- testsuite/tests/package/package06e.hs | 2 +- testsuite/tests/package/package06e.stderr | 2 +- testsuite/tests/package/package07e.hs | 6 +- testsuite/tests/package/package07e.stderr | 8 +- testsuite/tests/package/package08e.hs | 6 +- testsuite/tests/package/package08e.stderr | 8 +- testsuite/tests/parser/should_fail/readFail001.hs | 2 +- .../plugins/simple-plugin/Simple/RemovePlugin.hs | 8 +- .../plugins/simple-plugin/Simple/SourcePlugin.hs | 10 +- testsuite/tests/plugins/static-plugins.hs | 10 +- testsuite/tests/pmcheck/should_compile/pmc009.hs | 2 +- utils/check-ppr/Main.hs | 2 +- utils/haddock | 2 +- 153 files changed, 15726 insertions(+), 15722 deletions(-) create mode 100644 compiler/GHC/Hs.hs create mode 100644 compiler/GHC/Hs/Binds.hs create mode 100644 compiler/GHC/Hs/Decls.hs create mode 100644 compiler/GHC/Hs/Doc.hs create mode 100644 compiler/GHC/Hs/Dump.hs create mode 100644 compiler/GHC/Hs/Expr.hs create mode 100644 compiler/GHC/Hs/Expr.hs-boot create mode 100644 compiler/GHC/Hs/Extension.hs create mode 100644 compiler/GHC/Hs/ImpExp.hs create mode 100644 compiler/GHC/Hs/Instances.hs create mode 100644 compiler/GHC/Hs/Lit.hs create mode 100644 compiler/GHC/Hs/Pat.hs create mode 100644 compiler/GHC/Hs/Pat.hs-boot create mode 100644 compiler/GHC/Hs/PlaceHolder.hs create mode 100644 compiler/GHC/Hs/Types.hs create mode 100644 compiler/GHC/Hs/Utils.hs create mode 100644 compiler/GHC/ThToHs.hs delete mode 100644 compiler/hsSyn/Convert.hs delete mode 100644 compiler/hsSyn/HsBinds.hs delete mode 100644 compiler/hsSyn/HsDecls.hs delete mode 100644 compiler/hsSyn/HsDoc.hs delete mode 100644 compiler/hsSyn/HsDumpAst.hs delete mode 100644 compiler/hsSyn/HsExpr.hs delete mode 100644 compiler/hsSyn/HsExpr.hs-boot delete mode 100644 compiler/hsSyn/HsExtension.hs delete mode 100644 compiler/hsSyn/HsImpExp.hs delete mode 100644 compiler/hsSyn/HsInstances.hs delete mode 100644 compiler/hsSyn/HsLit.hs delete mode 100644 compiler/hsSyn/HsPat.hs delete mode 100644 compiler/hsSyn/HsPat.hs-boot delete mode 100644 compiler/hsSyn/HsSyn.hs delete mode 100644 compiler/hsSyn/HsTypes.hs delete mode 100644 compiler/hsSyn/HsUtils.hs delete mode 100644 compiler/hsSyn/PlaceHolder.hs diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs new file mode 100644 index 0000000000..aa345f1476 --- /dev/null +++ b/compiler/GHC/Hs.hs @@ -0,0 +1,153 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{Haskell abstract syntax definition} + +This module glues together the pieces of the Haskell abstract syntax, +which is declared in the various \tr{Hs*} modules. This module, +therefore, is almost nothing but re-exporting. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data + +module GHC.Hs ( + module GHC.Hs.Binds, + module GHC.Hs.Decls, + module GHC.Hs.Expr, + module GHC.Hs.ImpExp, + module GHC.Hs.Lit, + module GHC.Hs.Pat, + module GHC.Hs.Types, + module GHC.Hs.Utils, + module GHC.Hs.Doc, + module GHC.Hs.PlaceHolder, + module GHC.Hs.Extension, + Fixity, + + HsModule(..), +) where + +-- friends: +import GhcPrelude + +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr +import GHC.Hs.ImpExp +import GHC.Hs.Lit +import GHC.Hs.PlaceHolder +import GHC.Hs.Extension +import GHC.Hs.Pat +import GHC.Hs.Types +import BasicTypes ( Fixity, WarningTxt ) +import GHC.Hs.Utils +import GHC.Hs.Doc +import GHC.Hs.Instances () -- For Data instances + +-- others: +import Outputable +import SrcLoc +import Module ( ModuleName ) + +-- libraries: +import Data.Data hiding ( Fixity ) + +-- | Haskell Module +-- +-- All we actually declare here is the top-level structure for a module. +data HsModule pass + = HsModule { + hsmodName :: Maybe (Located ModuleName), + -- ^ @Nothing@: \"module X where\" is omitted (in which case the next + -- field is Nothing too) + hsmodExports :: Maybe (Located [LIE pass]), + -- ^ Export list + -- + -- - @Nothing@: export list omitted, so export everything + -- + -- - @Just []@: export /nothing/ + -- + -- - @Just [...]@: as you would expect... + -- + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + hsmodImports :: [LImportDecl pass], + -- ^ We snaffle interesting stuff out of the imported interfaces early + -- on, adding that info to TyDecls/etc; so this list is often empty, + -- downstream. + hsmodDecls :: [LHsDecl pass], + -- ^ Type, class, value, and interface signature decls + hsmodDeprecMessage :: Maybe (Located WarningTxt), + -- ^ reason\/explanation for warning/deprecation of this module + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + -- + + -- For details on above see note [Api annotations] in ApiAnnotation + hsmodHaddockModHeader :: Maybe LHsDocString + -- ^ Haddock module info and description, unparsed + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + } + -- ^ 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere' + -- + -- - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnClose' for explicit braces and semi around + -- hsmodImports,hsmodDecls if this style is used. + + -- For details on above see note [Api annotations] in ApiAnnotation +-- deriving instance (DataIdLR name name) => Data (HsModule name) +deriving instance Data (HsModule GhcPs) +deriving instance Data (HsModule GhcRn) +deriving instance Data (HsModule GhcTc) + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where + + ppr (HsModule Nothing _ imports decls _ mbDoc) + = pp_mb mbDoc $$ pp_nonnull imports + $$ pp_nonnull decls + + ppr (HsModule (Just name) exports imports decls deprec mbDoc) + = vcat [ + pp_mb mbDoc, + case exports of + Nothing -> pp_header (text "where") + Just es -> vcat [ + pp_header lparen, + nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), + nest 4 (text ") where") + ], + pp_nonnull imports, + pp_nonnull decls + ] + where + pp_header rest = case deprec of + Nothing -> pp_modname <+> rest + Just d -> vcat [ pp_modname, ppr d, rest ] + + pp_modname = text "module" <+> ppr name + +pp_mb :: Outputable t => Maybe t -> SDoc +pp_mb (Just x) = ppr x +pp_mb Nothing = empty + +pp_nonnull :: Outputable t => [t] -> SDoc +pp_nonnull [] = empty +pp_nonnull xs = vcat (map ppr xs) diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs new file mode 100644 index 0000000000..01c10b1ea1 --- /dev/null +++ b/compiler/GHC/Hs/Binds.hs @@ -0,0 +1,1310 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsBinds]{Abstract syntax: top-level bindings and signatures} + +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Hs.Binds where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, LHsExpr, + MatchGroup, pprFunBind, + GRHSs, pprPatBind ) +import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) + +import GHC.Hs.Extension +import GHC.Hs.Types +import CoreSyn +import TcEvidence +import Type +import NameSet +import BasicTypes +import Outputable +import SrcLoc +import Var +import Bag +import FastString +import BooleanFormula (LBooleanFormula) +import DynFlags + +import Data.Data hiding ( Fixity ) +import Data.List hiding ( foldr ) +import Data.Ord + +{- +************************************************************************ +* * +\subsection{Bindings: @BindGroup@} +* * +************************************************************************ + +Global bindings (where clauses) +-} + +-- During renaming, we need bindings where the left-hand sides +-- have been renamed but the right-hand sides have not. +-- the ...LR datatypes are parametrized by two id types, +-- one for the left and one for the right. +-- Other than during renaming, these will be the same. + +-- | Haskell Local Bindings +type HsLocalBinds id = HsLocalBindsLR id id + +-- | Located Haskell local bindings +type LHsLocalBinds id = Located (HsLocalBinds id) + +-- | Haskell Local Bindings with separate Left and Right identifier types +-- +-- Bindings in a 'let' expression +-- or a 'where' clause +data HsLocalBindsLR idL idR + = HsValBinds + (XHsValBinds idL idR) + (HsValBindsLR idL idR) + -- ^ Haskell Value Bindings + + -- There should be no pattern synonyms in the HsValBindsLR + -- These are *local* (not top level) bindings + -- The parser accepts them, however, leaving the + -- renamer to report them + + | HsIPBinds + (XHsIPBinds idL idR) + (HsIPBinds idR) + -- ^ Haskell Implicit Parameter Bindings + + | EmptyLocalBinds (XEmptyLocalBinds idL idR) + -- ^ Empty Local Bindings + + | XHsLocalBindsLR + (XXHsLocalBindsLR idL idR) + +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon + +type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) + + +-- | Haskell Value Bindings +type HsValBinds id = HsValBindsLR id id + +-- | Haskell Value bindings with separate Left and Right identifier types +-- (not implicit parameters) +-- Used for both top level and nested bindings +-- May contain pattern synonym bindings +data HsValBindsLR idL idR + = -- | Value Bindings In + -- + -- Before renaming RHS; idR is always RdrName + -- Not dependency analysed + -- Recursive by default + ValBinds + (XValBinds idL idR) + (LHsBindsLR idL idR) [LSig idR] + + -- | Value Bindings Out + -- + -- After renaming RHS; idR can be Name or Id Dependency analysed, + -- later bindings in the list may depend on earlier ones. + | XValBindsLR + (XXValBindsLR idL idR) + +-- --------------------------------------------------------------------- +-- Deal with ValBindsOut + +-- TODO: make this the only type for ValBinds +data NHsValBindsLR idL + = NValBinds + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] + +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXValBindsLR (GhcPass pL) (GhcPass pR) + = NHsValBindsLR (GhcPass pL) + +-- --------------------------------------------------------------------- + +-- | Located Haskell Binding +type LHsBind id = LHsBindLR id id + +-- | Located Haskell Bindings +type LHsBinds id = LHsBindsLR id id + +-- | Haskell Binding +type HsBind id = HsBindLR id id + +-- | Located Haskell Bindings with separate Left and Right identifier types +type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) + +-- | Located Haskell Binding with separate Left and Right identifier types +type LHsBindLR idL idR = Located (HsBindLR idL idR) + +{- Note [FunBind vs PatBind] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +The distinction between FunBind and PatBind is a bit subtle. FunBind covers +patterns which resemble function bindings and simple variable bindings. + + f x = e + f !x = e + f = e + !x = e -- FunRhs has SrcStrict + x `f` y = e -- FunRhs has Infix + +The actual patterns and RHSs of a FunBind are encoding in fun_matches. +The m_ctxt field of each Match in fun_matches will be FunRhs and carries +two bits of information about the match, + + * The mc_fixity field on each Match describes the fixity of the + function binder in that match. E.g. this is legal: + f True False = e1 + True `f` True = e2 + + * The mc_strictness field is used /only/ for nullary FunBinds: ones + with one Match, which has no pats. For these, it describes whether + the match is decorated with a bang (e.g. `!x = e`). + +By contrast, PatBind represents data constructor patterns, as well as a few +other interesting cases. Namely, + + Just x = e + (x) = e + x :: Ty = e +-} + +-- | Haskell Binding with separate Left and Right id's +data HsBindLR idL idR + = -- | Function-like Binding + -- + -- FunBind is used for both functions @f x = e@ + -- and variables @f = \x -> e@ + -- and strict variables @!x = x + 1@ + -- + -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. + -- + -- Reason 2: Instance decls can only have FunBinds, which is convenient. + -- If you change this, you'll need to change e.g. rnMethodBinds + -- + -- But note that the form @f :: a->a = ...@ + -- parses as a pattern binding, just like + -- @(f :: a -> a) = ... @ + -- + -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their + -- 'MatchContext'. See Note [FunBind vs PatBind] for + -- details about the relationship between FunBind and PatBind. + -- + -- 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches + -- + -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + FunBind { + + fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains + -- the locally-bound + -- free variables of this defn. + -- See Note [Bind free vars] + + fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr + + fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload + + fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of + -- the Id. Example: + -- + -- @ + -- f :: Int -> forall a. a -> a + -- f x y = y + -- @ + -- + -- Then the MatchGroup will have type (Int -> a' -> a') + -- (with a free type variable a'). The coercion will take + -- a CoreExpr of this type and convert it to a CoreExpr of + -- type Int -> forall a'. a' -> a' + -- Notice that the coercion captures the free a'. + + fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any + } + + -- | Pattern Binding + -- + -- The pattern is never a simple variable; + -- That case is done by FunBind. + -- See Note [FunBind vs PatBind] for details about the + -- relationship between FunBind and PatBind. + + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', + -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | PatBind { + pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] + pat_lhs :: LPat idL, + pat_rhs :: GRHSs idR (LHsExpr idR), + pat_ticks :: ([Tickish Id], [[Tickish Id]]) + -- ^ Ticks to put on the rhs, if any, and ticks to put on + -- the bound variables. + } + + -- | Variable Binding + -- + -- Dictionary binding and suchlike. + -- All VarBinds are introduced by the type checker + | VarBind { + var_ext :: XVarBind idL idR, + var_id :: IdP idL, + var_rhs :: LHsExpr idR, -- ^ Located only for consistency + var_inline :: Bool -- ^ True <=> inline this binding regardless + -- (used for implication constraints only) + } + + -- | Abstraction Bindings + | AbsBinds { -- Binds abstraction; TRANSLATION + abs_ext :: XAbsBinds idL idR, + abs_tvs :: [TyVar], + abs_ev_vars :: [EvVar], -- ^ Includes equality constraints + + -- | AbsBinds only gets used when idL = idR after renaming, + -- but these need to be idL's for the collect... code in HsUtil + -- to have the right type + abs_exports :: [ABExport idL], + + -- | Evidence bindings + -- Why a list? See TcInstDcls + -- Note [Typechecking plan for instance declarations] + abs_ev_binds :: [TcEvBinds], + + -- | Typechecked user bindings + abs_binds :: LHsBinds idL, + + abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] + } + + -- | Patterns Synonym Binding + | PatSynBind + (XPatSynBind idL idR) + (PatSynBind idL idR) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', + -- 'ApiAnnotation.AnnWhere' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | XHsBindsLR (XXHsBindsLR idL idR) + +data NPatBindTc = NPatBindTc { + pat_fvs :: NameSet, -- ^ Free variables + pat_rhs_ty :: Type -- ^ Type of the GRHSs + } deriving Data + +type instance XFunBind (GhcPass pL) GhcPs = NoExtField +type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables +type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables + +type instance XPatBind GhcPs (GhcPass pR) = NoExtField +type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables +type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc + +type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField +type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon + + + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] + -- + -- Creates bindings for (polymorphic, overloaded) poly_f + -- in terms of monomorphic, non-overloaded mono_f + -- + -- Invariants: + -- 1. 'binds' binds mono_f + -- 2. ftvs is a subset of tvs + -- 3. ftvs includes all tyvars free in ds + -- + -- See Note [AbsBinds] + +-- | Abtraction Bindings Export +data ABExport p + = ABE { abe_ext :: XABE p + , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id + , abe_mono :: IdP p + , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] + -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly + , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas + } + | XABExport (XXABExport p) + +type instance XABE (GhcPass p) = NoExtField +type instance XXABExport (GhcPass p) = NoExtCon + + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' +-- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, +-- 'ApiAnnotation.AnnClose' @'}'@, + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Pattern Synonym binding +data PatSynBind idL idR + = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs. + -- See Note [Bind free vars] + psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym + psb_args :: HsPatSynDetails (Located (IdP idR)), + -- ^ Formal parameter names + psb_def :: LPat idR, -- ^ Right-hand side + psb_dir :: HsPatSynDir idR -- ^ Directionality + } + | XPatSynBind (XXPatSynBind idL idR) + +type instance XPSB (GhcPass idL) GhcPs = NoExtField +type instance XPSB (GhcPass idL) GhcRn = NameSet +type instance XPSB (GhcPass idL) GhcTc = NameSet + +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExtCon + +{- +Note [AbsBinds] +~~~~~~~~~~~~~~~ +The AbsBinds constructor is used in the output of the type checker, to +record *typechecked* and *generalised* bindings. Specifically + + AbsBinds { abs_tvs = tvs + , abs_ev_vars = [d1,d2] + , abs_exports = [ABE { abe_poly = fp, abe_mono = fm + , abe_wrap = fwrap } + ABE { slly for g } ] + , abs_ev_binds = DBINDS + , abs_binds = BIND[fm,gm] } + +where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means + + fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ] + [ ; BIND[fm,gm] } ] + [ in fm ] + + gp = ...same again, with gm instead of fm + +The 'fwrap' is an impedence-matcher that typically does nothing; see +Note [ABExport wrapper]. + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND } + in (fm,gm) + +In general: + + * abs_tvs are the type variables over which the binding group is + generalised + * abs_ev_var are the evidence variables (usually dictionaries) + over which the binding group is generalised + * abs_binds are the monomorphic bindings + * abs_ex_binds are the evidence bindings that wrap the abs_binds + * abs_exports connects the monomorphic Ids bound by abs_binds + with the polymorphic Ids bound by the AbsBinds itself. + +For example, consider a module M, with this top-level binding, where +there is no type signature for M.reverse, + M.reverse [] = [] + M.reverse (x:xs) = M.reverse xs ++ [x] + +In Hindley-Milner, a recursive binding is typechecked with the +*recursive* uses being *monomorphic*. So after typechecking *and* +desugaring we will get something like this + + M.reverse :: forall a. [a] -> [a] + = /\a. letrec + reverse :: [a] -> [a] = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] + in reverse + +Notice that 'M.reverse' is polymorphic as expected, but there is a local +definition for plain 'reverse' which is *monomorphic*. The type variable +'a' scopes over the entire letrec. + +That's after desugaring. What about after type checking but before +desugaring? That's where AbsBinds comes in. It looks like this: + + AbsBinds { abs_tvs = [a] + , abs_ev_vars = [] + , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], + , abe_mono = reverse :: [a] -> [a]}] + , abs_ev_binds = {} + , abs_binds = { reverse :: [a] -> [a] + = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] } } + +Here, + + * abs_tvs says what type variables are abstracted over the binding + group, just 'a' in this case. + * abs_binds is the *monomorphic* bindings of the group + * abs_exports describes how to get the polymorphic Id 'M.reverse' + from the monomorphic one 'reverse' + +Notice that the *original* function (the polymorphic one you thought +you were defining) appears in the abe_poly field of the +abs_exports. The bindings in abs_binds are for fresh, local, Ids with +a *monomorphic* Id. + +If there is a group of mutually recursive (see Note [Polymorphic +recursion]) functions without type signatures, we get one AbsBinds +with the monomorphic versions of the bindings in abs_binds, and one +element of abe_exports for each variable bound in the mutually +recursive group. This is true even for pattern bindings. Example: + (f,g) = (\x -> x, f) +After type checking we get + AbsBinds { abs_tvs = [a] + , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a + , abe_mono = f :: a -> a } + , ABE { abe_poly = M.g :: forall a. a -> a + , abe_mono = g :: a -> a }] + , abs_binds = { (f,g) = (\x -> x, f) } + +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + Rec { f x = ...(g ef)... + + ; g :: forall a. [a] -> [a] + ; g y = ...(f eg)... } + +These bindings /are/ mutually recursive (f calls g, and g calls f). +But we can use the type signature for g to break the recursion, +like this: + + 1. Add g :: forall a. [a] -> [a] to the type environment + + 2. Typecheck the definition of f, all by itself, + including generalising it to find its most general + type, say f :: forall b. b -> b -> [b] + + 3. Extend the type environment with that type for f + + 4. Typecheck the definition of g, all by itself, + checking that it has the type claimed by its signature + +Steps 2 and 4 each generate a separate AbsBinds, so we end +up with + Rec { AbsBinds { ...for f ... } + ; AbsBinds { ...for g ... } } + +This approach allows both f and to call each other +polymorphically, even though only g has a signature. + +We get an AbsBinds that encompasses multiple source-program +bindings only when + * Each binding in the group has at least one binder that + lacks a user type signature + * The group forms a strongly connected component + + +Note [The abs_sig field of AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The abs_sig field supports a couple of special cases for bindings. +Consider + + x :: Num a => (# a, a #) + x = (# 3, 4 #) + +The general desugaring for AbsBinds would give + + x = /\a. \ ($dNum :: Num a) -> + letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in + xm + +But that has an illegal let-binding for an unboxed tuple. In this +case we'd prefer to generate the (more direct) + + x = /\ a. \ ($dNum :: Num a) -> + (# fromInteger $dNum 3, fromInteger $dNum 4 #) + +A similar thing happens with representation-polymorphic defns +(#11405): + + undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + undef = error "undef" + +Again, the vanilla desugaring gives a local let-binding for a +representation-polymorphic (undefm :: a), which is illegal. But +again we can desugar without a let: + + undef = /\ a. \ (d:HasCallStack) -> error a d "undef" + +The abs_sig field supports this direct desugaring, with no local +let-bining. When abs_sig = True + + * the abs_binds is single FunBind + + * the abs_exports is a singleton + + * we have a complete type sig for binder + and hence the abs_binds is non-recursive + (it binds the mono_id but refers to the poly_id + +These properties are exploited in DsBinds.dsAbsBinds to +generate code without a let-binding. + +Note [ABExport wrapper] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (f,g) = (\x.x, \y.y) +This ultimately desugars to something like this: + tup :: forall a b. (a->a, b->b) + tup = /\a b. (\x:a.x, \y:b.y) + f :: forall a. a -> a + f = /\a. case tup a Any of + (fm::a->a,gm:Any->Any) -> fm + ...similarly for g... + +The abe_wrap field deals with impedance-matching between + (/\a b. case tup a b of { (f,g) -> f }) +and the thing we really want, which may have fewer type +variables. The action happens in TcBinds.mkExport. + +Note [Bind free vars] +~~~~~~~~~~~~~~~~~~~~~ +The bind_fvs field of FunBind and PatBind records the free variables +of the definition. It is used for the following purposes + +a) Dependency analysis prior to type checking + (see TcBinds.tc_group) + +b) Deciding whether we can do generalisation of the binding + (see TcBinds.decideGeneralisationPlan) + +c) Deciding whether the binding can be used in static forms + (see TcExpr.checkClosedInStaticForm for the HsStatic case and + TcBinds.isClosedBndrGroup). + +Specifically, + + * bind_fvs includes all free vars that are defined in this module + (including top-level things and lexically scoped type variables) + + * bind_fvs excludes imported vars; this is just to keep the set smaller + + * Before renaming, and after typechecking, the field is unused; + it's just an error thunk +-} + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsLocalBindsLR idL idR) where + ppr (HsValBinds _ bs) = ppr bs + ppr (HsIPBinds _ bs) = ppr bs + ppr (EmptyLocalBinds _) = empty + ppr (XHsLocalBindsLR x) = ppr x + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsValBindsLR idL idR) where + ppr (ValBinds _ binds sigs) + = pprDeclList (pprLHsBindsForUser binds sigs) + + ppr (XValBindsLR (NValBinds sccs sigs)) + = getPprStyle $ \ sty -> + if debugStyle sty then -- Print with sccs showing + vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) + else + pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) + where + ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds + pp_rec Recursive = text "rec" + pp_rec NonRecursive = text "nonrec" + +pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = pprDeclList (map ppr (bagToList binds)) + +pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + OutputableBndrId (GhcPass id2)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] +-- pprLHsBindsForUser is different to pprLHsBinds because +-- a) No braces: 'let' and 'where' include a list of HsBindGroups +-- and we don't want several groups of bindings each +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser binds sigs + = map snd (sort_by_loc decls) + where + + decls :: [(SrcSpan, SDoc)] + decls = [(loc, ppr sig) | L loc sig <- sigs] ++ + [(loc, ppr bind) | L loc bind <- bagToList binds] + + sort_by_loc decls = sortBy (comparing fst) decls + +pprDeclList :: [SDoc] -> SDoc -- Braces with a space +-- Print a bunch of declarations +-- One could choose { d1; d2; ... }, using 'sep' +-- or d1 +-- d2 +-- .. +-- using vcat +-- At the moment we chose the latter +-- Also we do the 'pprDeeperList' thing. +pprDeclList ds = pprDeeperList vcat ds + +------------ +emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) +emptyLocalBinds = EmptyLocalBinds noExtField + +-- AZ:These functions do not seem to be used at all? +isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool +isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds +isEmptyLocalBindsTc (EmptyLocalBinds _) = True +isEmptyLocalBindsTc (XHsLocalBindsLR _) = True + +isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds +isEmptyLocalBindsPR (EmptyLocalBinds _) = True +isEmptyLocalBindsPR (XHsLocalBindsLR _) = True + +eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool +eqEmptyLocalBinds (EmptyLocalBinds _) = True +eqEmptyLocalBinds _ = False + +isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs + +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) +emptyValBindsIn = ValBinds noExtField emptyBag [] +emptyValBindsOut = XValBindsLR (NValBinds [] []) + +emptyLHsBinds :: LHsBindsLR idL idR +emptyLHsBinds = emptyBag + +isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool +isEmptyLHsBinds = isEmptyBag + +------------ +plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) + -> HsValBinds(GhcPass a) +plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) + = ValBinds noExtField (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) + (XValBindsLR (NValBinds ds2 sigs2)) + = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) +plusHsValBinds _ _ + = panic "HsBinds.plusHsValBinds" + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsBindLR idL idR) where + ppr mbind = ppr_monobind mbind + +ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc + +ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = pprPatBind pat grhss +ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) + = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] +ppr_monobind (FunBind { fun_id = fun, + fun_co_fn = wrap, + fun_matches = matches, + fun_tick = ticks }) + = pprTicks empty (if null ticks then empty + else text "-- ticks = " <> ppr ticks) + $$ whenPprDebug (pprBndr LetBind (unLoc fun)) + $$ pprFunBind matches + $$ whenPprDebug (ppr wrap) +ppr_monobind (PatSynBind _ psb) = ppr psb +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds + , abs_ev_binds = ev_binds }) + = sdocWithDynFlags $ \ dflags -> + if gopt Opt_PrintTypecheckerElaboration dflags then + -- Show extra information (bug number: #10662) + hang (text "AbsBinds" <+> brackets (interpp'SP tyvars) + <+> brackets (interpp'SP dictvars)) + 2 $ braces $ vcat + [ text "Exports:" <+> + brackets (sep (punctuate comma (map ppr exports))) + , text "Exported types:" <+> + vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] + , text "Binds:" <+> pprLHsBinds val_binds + , text "Evidence:" <+> ppr ev_binds ] + else + pprLHsBinds val_binds +ppr_monobind (XHsBindsLR x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where + ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) + = vcat [ ppr gbl <+> text "<=" <+> ppr lcl + , nest 2 (pprTcSpecPrags prags) + , nest 2 (text "wrap:" <+> ppr wrap)] + ppr (XABExport x) = ppr x + +instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR, + Outputable (XXPatSynBind idL idR)) + => Outputable (PatSynBind idL idR) where + ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, + psb_dir = dir }) + = ppr_lhs <+> ppr_rhs + where + ppr_lhs = text "pattern" <+> ppr_details + ppr_simple syntax = syntax <+> ppr pat + + ppr_details = case details of + InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] + PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs) + RecCon vs -> pprPrefixOcc psyn + <> braces (sep (punctuate comma (map ppr vs))) + + ppr_rhs = case dir of + Unidirectional -> ppr_simple (text "<-") + ImplicitBidirectional -> ppr_simple equals + ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ + (nest 2 $ pprFunBind mg) + ppr (XPatSynBind x) = ppr x + +pprTicks :: SDoc -> SDoc -> SDoc +-- Print stuff about ticks only when -dppr-debug is on, to avoid +-- them appearing in error messages (from the desugarer); see # 3263 +-- Also print ticks in dumpStyle, so that -ddump-hpc actually does +-- something useful. +pprTicks pp_no_debug pp_when_debug + = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty + then pp_when_debug + else pp_no_debug) + +{- +************************************************************************ +* * + Implicit parameter bindings +* * +************************************************************************ +-} + +-- | Haskell Implicit Parameter Bindings +data HsIPBinds id + = IPBinds + (XIPBinds id) + [LIPBind id] + -- TcEvBinds -- Only in typechecker output; binds + -- -- uses of the implicit parameters + | XHsIPBinds (XXHsIPBinds id) + +type instance XIPBinds GhcPs = NoExtField +type instance XIPBinds GhcRn = NoExtField +type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the + -- implicit parameters + + +type instance XXHsIPBinds (GhcPass p) = NoExtCon + +isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool +isEmptyIPBindsPR (IPBinds _ is) = null is +isEmptyIPBindsPR (XHsIPBinds _) = True + +isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool +isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds +isEmptyIPBindsTc (XHsIPBinds _) = True + +-- | Located Implicit Parameter Binding +type LIPBind id = Located (IPBind id) +-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a +-- list + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Implicit parameter bindings. +-- +-- These bindings start off as (Left "x") in the parser and stay +-- that way until after type-checking when they are replaced with +-- (Right d), where "d" is the name of the dictionary holding the +-- evidence for the implicit parameter. +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + +-- For details on above see note [Api annotations] in ApiAnnotation +data IPBind id + = IPBind + (XCIPBind id) + (Either (Located HsIPName) (IdP id)) + (LHsExpr id) + | XIPBind (XXIPBind id) + +type instance XCIPBind (GhcPass p) = NoExtField +type instance XXIPBind (GhcPass p) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsIPBinds p) where + ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) + $$ whenPprDebug (ppr ds) + ppr (XHsIPBinds x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where + ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) + where name = case lr of + Left (L _ ip) -> pprBndr LetBind ip + Right id -> pprBndr LetBind id + ppr (XIPBind x) = ppr x + +{- +************************************************************************ +* * +\subsection{@Sig@: type signatures and value-modifying user pragmas} +* * +************************************************************************ + +It is convenient to lump ``value-modifying'' user-pragmas (e.g., +``specialise this function to these four types...'') in with type +signatures. Then all the machinery to move them into place, etc., +serves for both. +-} + +-- | Located Signature +type LSig pass = Located (Sig pass) + +-- | Signatures and pragmas +data Sig pass + = -- | An ordinary type signature + -- + -- > f :: Num a => a -> a + -- + -- After renaming, this list of Names contains the named + -- wildcards brought into scope by this signature. For a signature + -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@ + -- untouched, and the named wildcard @_a@ is then replaced with + -- fresh meta vars in the type. Their names are stored in the type + -- signature that brought them into scope, in this third field to be + -- more specific. + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnComma' + + -- For details on above see note [Api annotations] in ApiAnnotation + TypeSig + (XTypeSig pass) + [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah + (LHsSigWcType pass) -- RHS of the signature; can have wildcards + + -- | A pattern synonym type signature + -- + -- > pattern Single :: () => (Show a) => a -> [a] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall' + -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass) + -- P :: forall a b. Req => Prov => ty + + -- | A signature for a class method + -- False: ordinary class-method signature + -- True: generic-default class method signature + -- e.g. class C a where + -- op :: a -> a -- Ordinary + -- default op :: Eq a => a -> a -- Generic default + -- No wildcards allowed here + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnDcolon' + | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass) + + -- | A type signature in generated code, notably the code + -- generated for record selectors. We simply record + -- the desired Id itself, replete with its name, type + -- and IdDetails. Otherwise it's just like a type + -- signature: there should be an accompanying binding + | IdSig (XIdSig pass) Id + + -- | An ordinary fixity declaration + -- + -- > infixl 8 *** + -- + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix', + -- 'ApiAnnotation.AnnVal' + + -- For details on above see note [Api annotations] in ApiAnnotation + | FixSig (XFixSig pass) (FixitySig pass) + + -- | An inline pragma + -- + -- > {#- INLINE f #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, + -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | InlineSig (XInlineSig pass) + (Located (IdP pass)) -- Function name + InlinePragma -- Never defaultInlinePragma + + -- | A specialisation pragma + -- + -- > {-# SPECIALISE f :: Int -> Int #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, + -- 'ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, + -- 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SpecSig (XSpecSig pass) + (Located (IdP pass)) -- Specialise a function or datatype ... + [LHsSigType pass] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE + + -- | A specialisation pragma for instance declarations only + -- + -- > {-# SPECIALISE instance Eq [Int] #-} + -- + -- (Class tys); should be a specialisation of the + -- current instance declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) + -- Note [Pragma source text] in BasicTypes + + -- | A minimal complete definition pragma + -- + -- > {-# MINIMAL a | (b, c | (d | e)) #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | MinimalSig (XMinimalSig pass) + SourceText (LBooleanFormula (Located (IdP pass))) + -- Note [Pragma source text] in BasicTypes + + -- | A "set cost centre" pragma for declarations + -- + -- > {-# SCC funName #-} + -- + -- or + -- + -- > {-# SCC funName "cost_centre_name" #-} + + | SCCFunSig (XSCCFunSig pass) + SourceText -- Note [Pragma source text] in BasicTypes + (Located (IdP pass)) -- Function name + (Maybe (Located StringLiteral)) + -- | A complete match pragma + -- + -- > {-# COMPLETE C, D [:: T] #-} + -- + -- Used to inform the pattern match checker about additional + -- complete matchings which, for example, arise from pattern + -- synonym definitions. + | CompleteMatchSig (XCompleteMatchSig pass) + SourceText + (Located [Located (IdP pass)]) + (Maybe (Located (IdP pass))) + | XSig (XXSig pass) + +type instance XTypeSig (GhcPass p) = NoExtField +type instance XPatSynSig (GhcPass p) = NoExtField +type instance XClassOpSig (GhcPass p) = NoExtField +type instance XIdSig (GhcPass p) = NoExtField +type instance XFixSig (GhcPass p) = NoExtField +type instance XInlineSig (GhcPass p) = NoExtField +type instance XSpecSig (GhcPass p) = NoExtField +type instance XSpecInstSig (GhcPass p) = NoExtField +type instance XMinimalSig (GhcPass p) = NoExtField +type instance XSCCFunSig (GhcPass p) = NoExtField +type instance XCompleteMatchSig (GhcPass p) = NoExtField +type instance XXSig (GhcPass p) = NoExtCon + +-- | Located Fixity Signature +type LFixitySig pass = Located (FixitySig pass) + +-- | Fixity Signature +data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity + | XFixitySig (XXFixitySig pass) + +type instance XFixitySig (GhcPass p) = NoExtField +type instance XXFixitySig (GhcPass p) = NoExtCon + +-- | Type checker Specialisation Pragmas +-- +-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer +data TcSpecPrags + = IsDefaultMethod -- ^ Super-specialised: a default method should + -- be macro-expanded at every call site + | SpecPrags [LTcSpecPrag] + deriving Data + +-- | Located Type checker Specification Pragmas +type LTcSpecPrag = Located TcSpecPrag + +-- | Type checker Specification Pragma +data TcSpecPrag + = SpecPrag + Id + HsWrapper + InlinePragma + -- ^ The Id to be specialised, a wrapper that specialises the + -- polymorphic function, and inlining spec for the specialised function + deriving Data + +noSpecPrags :: TcSpecPrags +noSpecPrags = SpecPrags [] + +hasSpecPrags :: TcSpecPrags -> Bool +hasSpecPrags (SpecPrags ps) = not (null ps) +hasSpecPrags IsDefaultMethod = False + +isDefaultMethod :: TcSpecPrags -> Bool +isDefaultMethod IsDefaultMethod = True +isDefaultMethod (SpecPrags {}) = False + + +isFixityLSig :: LSig name -> Bool +isFixityLSig (L _ (FixSig {})) = True +isFixityLSig _ = False + +isTypeLSig :: LSig name -> Bool -- Type signatures +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(ClassOpSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False + +isSpecLSig :: LSig name -> Bool +isSpecLSig (L _(SpecSig {})) = True +isSpecLSig _ = False + +isSpecInstLSig :: LSig name -> Bool +isSpecInstLSig (L _ (SpecInstSig {})) = True +isSpecInstLSig _ = False + +isPragLSig :: LSig name -> Bool +-- Identifies pragmas +isPragLSig (L _ (SpecSig {})) = True +isPragLSig (L _ (InlineSig {})) = True +isPragLSig (L _ (SCCFunSig {})) = True +isPragLSig (L _ (CompleteMatchSig {})) = True +isPragLSig _ = False + +isInlineLSig :: LSig name -> Bool +-- Identifies inline pragmas +isInlineLSig (L _ (InlineSig {})) = True +isInlineLSig _ = False + +isMinimalLSig :: LSig name -> Bool +isMinimalLSig (L _ (MinimalSig {})) = True +isMinimalLSig _ = False + +isSCCFunSig :: LSig name -> Bool +isSCCFunSig (L _ (SCCFunSig {})) = True +isSCCFunSig _ = False + +isCompleteMatchSig :: LSig name -> Bool +isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True +isCompleteMatchSig _ = False + +hsSigDoc :: Sig name -> SDoc +hsSigDoc (TypeSig {}) = text "type signature" +hsSigDoc (PatSynSig {}) = text "pattern synonym signature" +hsSigDoc (ClassOpSig _ is_deflt _ _) + | is_deflt = text "default type signature" + | otherwise = text "class method signature" +hsSigDoc (IdSig {}) = text "id signature" +hsSigDoc (SpecSig {}) = text "SPECIALISE pragma" +hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" +hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" +hsSigDoc (FixSig {}) = text "fixity declaration" +hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" +hsSigDoc (SCCFunSig {}) = text "SCC pragma" +hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig {}) = text "XSIG TTG extension" + +{- +Check if signatures overlap; this is used when checking for duplicate +signatures. Since some of the signatures contain a list of names, testing for +equality is not enough -- we have to check if they overlap. +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where + ppr sig = ppr_sig sig + +ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc +ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (ClassOpSig _ is_deflt vars ty) + | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) + | otherwise = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) +ppr_sig (FixSig _ fix_sig) = ppr fix_sig +ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) + = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) + (interpp'SP ty) inl) + where + pragmaSrc = case spec of + NoUserInline -> "{-# SPECIALISE" + _ -> "{-# SPECIALISE_INLINE" +ppr_sig (InlineSig _ var inl) + = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl + <+> pprPrefixOcc (unLoc var)) +ppr_sig (SpecInstSig _ src ty) + = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty) +ppr_sig (MinimalSig _ src bf) + = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) +ppr_sig (PatSynSig _ names sig_ty) + = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) +ppr_sig (SCCFunSig _ src fn mlabel) + = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) +ppr_sig (CompleteMatchSig _ src cs mty) + = pragSrcBrackets src "{-# COMPLETE" + ((hsep (punctuate comma (map ppr (unLoc cs)))) + <+> opt_sig) + where + opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty +ppr_sig (XSig x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (FixitySig p) where + ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] + where + pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) + ppr (XFixitySig x) = ppr x + +pragBrackets :: SDoc -> SDoc +pragBrackets doc = text "{-#" <+> doc <+> text "#-}" + +-- | Using SourceText in case the pragma was spelled differently or used mixed +-- case +pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc +pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}" +pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" + +pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc +pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] + where + pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) + +pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc +pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty + where + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = pprInline inl + +pprTcSpecPrags :: TcSpecPrags -> SDoc +pprTcSpecPrags IsDefaultMethod = text "" +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) + +instance Outputable TcSpecPrag where + ppr (SpecPrag var _ inl) + = text "SPECIALIZE" <+> pprSpec var (text "") inl + +pprMinimalSig :: (OutputableBndr name) + => LBooleanFormula (Located name) -> SDoc +pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) + +{- +************************************************************************ +* * +\subsection[PatSynBind]{A pattern synonym definition} +* * +************************************************************************ +-} + +-- | Haskell Pattern Synonym Details +type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg] + +-- See Note [Record PatSyn Fields] +-- | Record Pattern Synonym Field +data RecordPatSynField a + = RecordPatSynField { + recordPatSynSelectorId :: a -- Selector name visible in rest of the file + , recordPatSynPatVar :: a + -- Filled in by renamer, the name used internally + -- by the pattern + } deriving (Data, Functor) + + + +{- +Note [Record PatSyn Fields] + +Consider the following two pattern synonyms. + +pattern P x y = ([x,True], [y,'v']) +pattern Q{ x, y } =([x,True], [y,'v']) + +In P, we just have two local binders, x and y. + +In Q, we have local binders but also top-level record selectors +x :: ([Bool], [Char]) -> Bool and similarly for y. + +It would make sense to support record-like syntax + +pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) + +when we have a different name for the local and top-level binder +the distinction between the two names clear + +-} +instance Outputable a => Outputable (RecordPatSynField a) where + ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v + +instance Foldable RecordPatSynField where + foldMap f (RecordPatSynField { recordPatSynSelectorId = visible + , recordPatSynPatVar = hidden }) + = f visible `mappend` f hidden + +instance Traversable RecordPatSynField where + traverse f (RecordPatSynField { recordPatSynSelectorId =visible + , recordPatSynPatVar = hidden }) + = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id + , recordPatSynPatVar = pat_var }) + <$> f visible <*> f hidden + + +-- | Haskell Pattern Synonym Direction +data HsPatSynDir id + = Unidirectional + | ImplicitBidirectional + | ExplicitBidirectional (MatchGroup id (LHsExpr id)) diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs new file mode 100644 index 0000000000..701c8b1a06 --- /dev/null +++ b/compiler/GHC/Hs/Decls.hs @@ -0,0 +1,2417 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Abstract syntax of global declarations. +-- +-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, +-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. +module GHC.Hs.Decls ( + -- * Toplevel declarations + HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, + HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour, + + -- ** Class or type declarations + TyClDecl(..), LTyClDecl, DataDeclRn(..), + TyClGroup(..), + tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, + isClassDecl, isDataDecl, isSynDecl, tcdName, + isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, + isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, + tyFamInstDeclName, tyFamInstDeclLName, + countTyClDecls, pprTyClDeclFlavour, + tyClDeclLName, tyClDeclTyVars, + hsDeclHasCusk, famDeclHasCusk, + FamilyDecl(..), LFamilyDecl, + + -- ** Instance declarations + InstDecl(..), LInstDecl, FamilyInfo(..), + TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, + TyFamDefltDecl, LTyFamDefltDecl, + DataFamInstDecl(..), LDataFamInstDecl, + pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS, + FamInstEqn, LFamInstEqn, FamEqn(..), + TyFamInstEqn, LTyFamInstEqn, HsTyPats, + LClsInstDecl, ClsInstDecl(..), + + -- ** Standalone deriving declarations + DerivDecl(..), LDerivDecl, + -- ** Deriving strategies + DerivStrategy(..), LDerivStrategy, + derivStrategyName, foldDerivStrategy, mapDerivStrategy, + -- ** @RULE@ declarations + LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), + RuleBndr(..),LRuleBndr, + collectRuleBndrSigTys, + flattenRuleDecls, pprFullRuleName, + -- ** @default@ declarations + DefaultDecl(..), LDefaultDecl, + -- ** Template haskell declaration splice + SpliceExplicitFlag(..), + SpliceDecl(..), LSpliceDecl, + -- ** Foreign function interface declarations + ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), + CImportSpec(..), + -- ** Data-constructor declarations + ConDecl(..), LConDecl, + HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta, + getConNames, getConArgs, + -- ** Document comments + DocDecl(..), LDocDecl, docDeclDoc, + -- ** Deprecations + WarnDecl(..), LWarnDecl, + WarnDecls(..), LWarnDecls, + -- ** Annotations + AnnDecl(..), LAnnDecl, + AnnProvenance(..), annProvenanceName_maybe, + -- ** Role annotations + RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName, + -- ** Injective type families + FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, + resultVariableName, + + -- * Grouping + HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls + + ) where + +-- friends: +import GhcPrelude + +import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, HsSplice, pprExpr, + pprSpliceDecl ) + -- Because Expr imports Decls via HsBracket + +import GHC.Hs.Binds +import GHC.Hs.Types +import GHC.Hs.Doc +import TyCon +import BasicTypes +import Coercion +import ForeignCall +import GHC.Hs.Extension +import NameSet + +-- others: +import Class +import Outputable +import Util +import SrcLoc +import Type + +import Bag +import Maybes +import Data.Data hiding (TyCon,Fixity, Infix) + +{- +************************************************************************ +* * +\subsection[HsDecl]{Declarations} +* * +************************************************************************ +-} + +type LHsDecl p = Located (HsDecl p) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | A Haskell Declaration +data HsDecl p + = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration + | InstD (XInstD p) (InstDecl p) -- ^ Instance declaration + | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration + | ValD (XValD p) (HsBind p) -- ^ Value declaration + | SigD (XSigD p) (Sig p) -- ^ Signature declaration + | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration + | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration + | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration + | AnnD (XAnnD p) (AnnDecl p) -- ^ Annotation declaration + | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration + | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration + -- (Includes quasi-quotes) + | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration + | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration + | XHsDecl (XXHsDecl p) + +type instance XTyClD (GhcPass _) = NoExtField +type instance XInstD (GhcPass _) = NoExtField +type instance XDerivD (GhcPass _) = NoExtField +type instance XValD (GhcPass _) = NoExtField +type instance XSigD (GhcPass _) = NoExtField +type instance XDefD (GhcPass _) = NoExtField +type instance XForD (GhcPass _) = NoExtField +type instance XWarningD (GhcPass _) = NoExtField +type instance XAnnD (GhcPass _) = NoExtField +type instance XRuleD (GhcPass _) = NoExtField +type instance XSpliceD (GhcPass _) = NoExtField +type instance XDocD (GhcPass _) = NoExtField +type instance XRoleAnnotD (GhcPass _) = NoExtField +type instance XXHsDecl (GhcPass _) = NoExtCon + +-- NB: all top-level fixity decls are contained EITHER +-- EITHER SigDs +-- OR in the ClassDecls in TyClDs +-- +-- The former covers +-- a) data constructors +-- b) class methods (but they can be also done in the +-- signatures of class decls) +-- c) imported functions (that have an IfacSig) +-- d) top level decls +-- +-- The latter is for class methods only + +-- | Haskell Group +-- +-- A 'HsDecl' is categorised into a 'HsGroup' before being +-- fed to the renamer. +data HsGroup p + = HsGroup { + hs_ext :: XCHsGroup p, + hs_valds :: HsValBinds p, + hs_splcds :: [LSpliceDecl p], + + hs_tyclds :: [TyClGroup p], + -- A list of mutually-recursive groups; + -- This includes `InstDecl`s as well; + -- Parser generates a singleton list; + -- renamer does dependency analysis + + hs_derivds :: [LDerivDecl p], + + hs_fixds :: [LFixitySig p], + -- Snaffled out of both top-level fixity signatures, + -- and those in class declarations + + hs_defds :: [LDefaultDecl p], + hs_fords :: [LForeignDecl p], + hs_warnds :: [LWarnDecls p], + hs_annds :: [LAnnDecl p], + hs_ruleds :: [LRuleDecls p], + + hs_docs :: [LDocDecl] + } + | XHsGroup (XXHsGroup p) + +type instance XCHsGroup (GhcPass _) = NoExtField +type instance XXHsGroup (GhcPass _) = NoExtCon + + +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) +emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } +emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } + +hsGroupInstDecls :: HsGroup id -> [LInstDecl id] +hsGroupInstDecls = (=<<) group_instds . hs_tyclds + +emptyGroup = HsGroup { hs_ext = noExtField, + hs_tyclds = [], + hs_derivds = [], + hs_fixds = [], hs_defds = [], hs_annds = [], + hs_fords = [], hs_warnds = [], hs_ruleds = [], + hs_valds = error "emptyGroup hs_valds: Can't happen", + hs_splcds = [], + hs_docs = [] } + +appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) + -> HsGroup (GhcPass p) +appendGroups + HsGroup { + hs_valds = val_groups1, + hs_splcds = spliceds1, + hs_tyclds = tyclds1, + hs_derivds = derivds1, + hs_fixds = fixds1, + hs_defds = defds1, + hs_annds = annds1, + hs_fords = fords1, + hs_warnds = warnds1, + hs_ruleds = rulds1, + hs_docs = docs1 } + HsGroup { + hs_valds = val_groups2, + hs_splcds = spliceds2, + hs_tyclds = tyclds2, + hs_derivds = derivds2, + hs_fixds = fixds2, + hs_defds = defds2, + hs_annds = annds2, + hs_fords = fords2, + hs_warnds = warnds2, + hs_ruleds = rulds2, + hs_docs = docs2 } + = + HsGroup { + hs_ext = noExtField, + hs_valds = val_groups1 `plusHsValBinds` val_groups2, + hs_splcds = spliceds1 ++ spliceds2, + hs_tyclds = tyclds1 ++ tyclds2, + hs_derivds = derivds1 ++ derivds2, + hs_fixds = fixds1 ++ fixds2, + hs_annds = annds1 ++ annds2, + hs_defds = defds1 ++ defds2, + hs_fords = fords1 ++ fords2, + hs_warnds = warnds1 ++ warnds2, + hs_ruleds = rulds1 ++ rulds2, + hs_docs = docs1 ++ docs2 } +appendGroups _ _ = panic "appendGroups" + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where + ppr (TyClD _ dcl) = ppr dcl + ppr (ValD _ binds) = ppr binds + ppr (DefD _ def) = ppr def + ppr (InstD _ inst) = ppr inst + ppr (DerivD _ deriv) = ppr deriv + ppr (ForD _ fd) = ppr fd + ppr (SigD _ sd) = ppr sd + ppr (RuleD _ rd) = ppr rd + ppr (WarningD _ wd) = ppr wd + ppr (AnnD _ ad) = ppr ad + ppr (SpliceD _ dd) = ppr dd + ppr (DocD _ doc) = ppr doc + ppr (RoleAnnotD _ ra) = ppr ra + ppr (XHsDecl x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where + ppr (HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = deprec_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls }) + = vcat_mb empty + [ppr_ds fix_decls, ppr_ds default_decls, + ppr_ds deprec_decls, ppr_ds ann_decls, + ppr_ds rule_decls, + if isEmptyValBinds val_decls + then Nothing + else Just (ppr val_decls), + ppr_ds (tyClGroupRoleDecls tycl_decls), + ppr_ds (tyClGroupTyClDecls tycl_decls), + ppr_ds (tyClGroupInstDecls tycl_decls), + ppr_ds deriv_decls, + ppr_ds foreign_decls] + where + ppr_ds :: Outputable a => [a] -> Maybe SDoc + ppr_ds [] = Nothing + ppr_ds ds = Just (vcat (map ppr ds)) + + vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc + -- Concatenate vertically with white-space between non-blanks + vcat_mb _ [] = empty + vcat_mb gap (Nothing : ds) = vcat_mb gap ds + vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds + ppr (XHsGroup x) = ppr x + +-- | Located Splice Declaration +type LSpliceDecl pass = Located (SpliceDecl pass) + +-- | Splice Declaration +data SpliceDecl p + = SpliceDecl -- Top level splice + (XSpliceDecl p) + (Located (HsSplice p)) + SpliceExplicitFlag + | XSpliceDecl (XXSpliceDecl p) + +type instance XSpliceDecl (GhcPass _) = NoExtField +type instance XXSpliceDecl (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (SpliceDecl p) where + ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f + ppr (XSpliceDecl x) = ppr x + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ + +Note [The Naming story] +~~~~~~~~~~~~~~~~~~~~~~~ +Here is the story about the implicit names that go with type, class, +and instance decls. It's a bit tricky, so pay attention! + +"Implicit" (or "system") binders +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Each data type decl defines + a worker name for each constructor + to-T and from-T convertors + Each class decl defines + a tycon for the class + a data constructor for that tycon + the worker for that constructor + a selector for each superclass + +All have occurrence names that are derived uniquely from their parent +declaration. + +None of these get separate definitions in an interface file; they are +fully defined by the data or class decl. But they may *occur* in +interface files, of course. Any such occurrence must haul in the +relevant type or class decl. + +Plan of attack: + - Ensure they "point to" the parent data/class decl + when loading that decl from an interface file + (See RnHiFiles.getSysBinders) + + - When typechecking the decl, we build the implicit TyCons and Ids. + When doing so we look them up in the name cache (RnEnv.lookupSysName), + to ensure correct module and provenance is set + +These are the two places that we have to conjure up the magic derived +names. (The actual magic is in OccName.mkWorkerOcc, etc.) + +Default methods +~~~~~~~~~~~~~~~ + - Occurrence name is derived uniquely from the method name + E.g. $dmmax + + - If there is a default method name at all, it's recorded in + the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field. + (DefMethInfo is defined in Class.hs) + +Source-code class decls and interface-code class decls are treated subtly +differently, which has given me a great deal of confusion over the years. +Here's the deal. (We distinguish the two cases because source-code decls +have (Just binds) in the tcdMeths field, whereas interface decls have Nothing. + +In *source-code* class declarations: + + - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName + This is done by RdrHsSyn.mkClassOpSigDM + + - The renamer renames it to a Name + + - During typechecking, we generate a binding for each $dm for + which there's a programmer-supplied default method: + class Foo a where + op1 :: + op2 :: + op1 = ... + We generate a binding for $dmop1 but not for $dmop2. + The Class for Foo has a Nothing for op2 and + a Just ($dm_op1, VanillaDM) for op1. + The Name for $dmop2 is simply discarded. + +In *interface-file* class declarations: + - When parsing, we see if there's an explicit programmer-supplied default method + because there's an '=' sign to indicate it: + class Foo a where + op1 = :: -- NB the '=' + op2 :: + We use this info to generate a DefMeth with a suitable RdrName for op1, + and a NoDefMeth for op2 + - The interface file has a separate definition for $dmop1, with unfolding etc. + - The renamer renames it to a Name. + - The renamer treats $dmop1 as a free variable of the declaration, so that + the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs) + This doesn't happen for source code class decls, because they *bind* the default method. + +Dictionary functions +~~~~~~~~~~~~~~~~~~~~ +Each instance declaration gives rise to one dictionary function binding. + +The type checker makes up new source-code instance declarations +(e.g. from 'deriving' or generic default methods --- see +TcInstDcls.tcInstDecls1). So we can't generate the names for +dictionary functions in advance (we don't know how many we need). + +On the other hand for interface-file instance declarations, the decl +specifies the name of the dictionary function, and it has a binding elsewhere +in the interface file: + instance {Eq Int} = dEqInt + dEqInt :: {Eq Int} + +So again we treat source code and interface file code slightly differently. + +Source code: + - Source code instance decls have a Nothing in the (Maybe name) field + (see data InstDecl below) + + - The typechecker makes up a Local name for the dict fun for any source-code + instance decl, whether it comes from a source-code instance decl, or whether + the instance decl is derived from some other construct (e.g. 'deriving'). + + - The occurrence name it chooses is derived from the instance decl (just for + documentation really) --- e.g. dNumInt. Two dict funs may share a common + occurrence name, but will have different uniques. E.g. + instance Foo [Int] where ... + instance Foo [Bool] where ... + These might both be dFooList + + - The CoreTidy phase externalises the name, and ensures the occurrence name is + unique (this isn't special to dict funs). So we'd get dFooList and dFooList1. + + - We can take this relaxed approach (changing the occurrence name later) + because dict fun Ids are not captured in a TyCon or Class (unlike default + methods, say). Instead, they are kept separately in the InstEnv. This + makes it easy to adjust them after compiling a module. (Once we've finished + compiling that module, they don't change any more.) + + +Interface file code: + - The instance decl gives the dict fun name, so the InstDecl has a (Just name) + in the (Maybe name) field. + + - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we + suck in the dfun binding +-} + +-- | Located Declaration of a Type or Class +type LTyClDecl pass = Located (TyClDecl pass) + +-- | A type or class declaration. +data TyClDecl pass + = -- | @type/data family T :: *->*@ + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP', + -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow', + -- 'ApiAnnotation.AnnVbar' + + -- For details on above see note [Api annotations] in ApiAnnotation + FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } + + | -- | @type@ declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnEqual', + + -- For details on above see note [Api annotations] in ApiAnnotation + SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an + -- associated type these + -- include outer binders + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdRhs :: LHsType pass } -- ^ RHS of type declaration + + | -- | @data@ declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnFamily', + -- 'ApiAnnotation.AnnNewType', + -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon' + -- 'ApiAnnotation.AnnWhere', + + -- For details on above see note [Api annotations] in ApiAnnotation + DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables + -- See Note [TyVar binders for associated declarations] + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdDataDefn :: HsDataDefn pass } + + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: LHsContext pass, -- ^ Context... + tcdLName :: Located (IdP pass), -- ^ Name of the class + tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables + tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration + tcdFDs :: [LHsFunDep pass], -- ^ Functional deps + tcdSigs :: [LSig pass], -- ^ Methods' signatures + tcdMeths :: LHsBinds pass, -- ^ Default methods + tcdATs :: [LFamilyDecl pass], -- ^ Associated types; + tcdATDefs :: [LTyFamDefltDecl pass], -- ^ Associated type defaults + tcdDocs :: [LDocDecl] -- ^ Haddock docs + } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + -- - The tcdFDs will have 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnComma' + -- 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XTyClDecl (XXTyClDecl pass) + +type LHsFunDep pass = Located (FunDep (Located (IdP pass))) + +data DataDeclRn = DataDeclRn + { tcdDataCusk :: Bool -- ^ does this have a CUSK? + -- See Note [CUSKs: complete user-supplied kind signatures] + , tcdFVs :: NameSet } + deriving Data + +{- Note [TyVar binders for associated decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For an /associated/ data, newtype, or type-family decl, the LHsQTyVars +/includes/ outer binders. For example + class T a where + data D a c + type F a b :: * + type F a b = a -> a +Here the data decl for 'D', and type-family decl for 'F', both include 'a' +in their LHsQTyVars (tcdTyVars and fdTyVars resp). + +Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars. + +The idea is that the associated type is really a top-level decl in its +own right. However we are careful to use the same name 'a', so that +we can match things up. + +c.f. Note [Associated type tyvar names] in Class.hs + Note [Family instance declaration binders] +-} + +type instance XFamDecl (GhcPass _) = NoExtField + +type instance XSynDecl GhcPs = NoExtField +type instance XSynDecl GhcRn = NameSet -- FVs +type instance XSynDecl GhcTc = NameSet -- FVs + +type instance XDataDecl GhcPs = NoExtField +type instance XDataDecl GhcRn = DataDeclRn +type instance XDataDecl GhcTc = DataDeclRn + +type instance XClassDecl GhcPs = NoExtField +type instance XClassDecl GhcRn = NameSet -- FVs +type instance XClassDecl GhcTc = NameSet -- FVs + +type instance XXTyClDecl (GhcPass _) = NoExtCon + +-- Simple classifiers for TyClDecl +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- | @True@ <=> argument is a @data@\/@newtype@ +-- declaration. +isDataDecl :: TyClDecl pass -> Bool +isDataDecl (DataDecl {}) = True +isDataDecl _other = False + +-- | type or type instance declaration +isSynDecl :: TyClDecl pass -> Bool +isSynDecl (SynDecl {}) = True +isSynDecl _other = False + +-- | type class +isClassDecl :: TyClDecl pass -> Bool +isClassDecl (ClassDecl {}) = True +isClassDecl _ = False + +-- | type/data family declaration +isFamilyDecl :: TyClDecl pass -> Bool +isFamilyDecl (FamDecl {}) = True +isFamilyDecl _other = False + +-- | type family declaration +isTypeFamilyDecl :: TyClDecl pass -> Bool +isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of + OpenTypeFamily -> True + ClosedTypeFamily {} -> True + _ -> False +isTypeFamilyDecl _ = False + +-- | open type family info +isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool +isOpenTypeFamilyInfo OpenTypeFamily = True +isOpenTypeFamilyInfo _ = False + +-- | closed type family info +isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool +isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True +isClosedTypeFamilyInfo _ = False + +-- | data family declaration +isDataFamilyDecl :: TyClDecl pass -> Bool +isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True +isDataFamilyDecl _other = False + +-- Dealing with names + +tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p) +tyFamInstDeclName = unLoc . tyFamInstDeclLName + +tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p)) +tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = + (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) + = ln +tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec))) + = noExtCon nec +tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec + +tyClDeclLName :: TyClDecl pass -> Located (IdP pass) +tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln +tyClDeclLName decl = tcdLName decl + +tcdName :: TyClDecl pass -> (IdP pass) +tcdName = unLoc . tyClDeclLName + +tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass +tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs +tyClDeclTyVars d = tcdTyVars d + +countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls +countTyClDecls decls + = (count isClassDecl decls, + count isSynDecl decls, -- excluding... + count isDataTy decls, -- ...family... + count isNewTy decls, -- ...instances + count isFamilyDecl decls) + where + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True + isDataTy _ = False + + isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True + isNewTy _ = False + +-- | Does this declaration have a complete, user-supplied kind signature? +-- See Note [CUSKs: complete user-supplied kind signatures] +hsDeclHasCusk + :: Bool -- True <=> the -XCUSKs extension is enabled + -> TyClDecl GhcRn + -> Bool +hsDeclHasCusk _cusks_enabled@False _ = False +hsDeclHasCusk cusks_enabled (FamDecl { tcdFam = fam_decl }) + = famDeclHasCusk cusks_enabled False fam_decl + -- False: this is not: an associated type of a class with no cusk +hsDeclHasCusk _cusks_enabled@True (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) + -- NB: Keep this synchronized with 'getInitialKind' + = hsTvbAllKinded tyvars && rhs_annotated rhs + where + rhs_annotated (L _ ty) = case ty of + HsParTy _ lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False +hsDeclHasCusk _cusks_enabled@True (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk +hsDeclHasCusk _cusks_enabled@True (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars +hsDeclHasCusk _ (XTyClDecl nec) = noExtCon nec + +-- Pretty-printing TyClDecl +-- ~~~~~~~~~~~~~~~~~~~~~~~~ + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where + + ppr (FamDecl { tcdFam = decl }) = ppr decl + ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdRhs = rhs }) + = hang (text "type" <+> + pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals) + 4 (ppr rhs) + + ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdDataDefn = defn }) + = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn + + ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs}) + | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part + = top_matter + + | otherwise -- Laid out + = vcat [ top_matter <+> text "where" + , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++ + map (pprTyFamDefltDecl . unLoc) at_defs ++ + pprLHsBindsForUser methods sigs) ] + where + top_matter = text "class" + <+> pp_vanilla_decl_head lclas tyvars fixity context + <+> pprFundeps (map unLoc fds) + + ppr (XTyClDecl x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (TyClGroup p) where + ppr (TyClGroup { group_tyclds = tyclds + , group_roles = roles + , group_instds = instds + } + ) + = ppr tyclds $$ + ppr roles $$ + ppr instds + ppr (XTyClGroup x) = ppr x + +pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p)) + => Located (IdP (GhcPass p)) + -> LHsQTyVars (GhcPass p) + -> LexicalFixity + -> LHsContext (GhcPass p) + -> SDoc +pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context + = hsep [pprLHsContext context, pp_tyvars tyvars] + where + pp_tyvars (varl:varsr) + | fixity == Infix && length varsr > 1 + = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) + , (ppr.unLoc) (head varsr), char ')' + , hsep (map (ppr.unLoc) (tail varsr))] + | fixity == Infix + = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) + , hsep (map (ppr.unLoc) varsr)] + | otherwise = hsep [ pprPrefixOcc (unLoc thing) + , hsep (map (ppr.unLoc) (varl:varsr))] + pp_tyvars [] = pprPrefixOcc (unLoc thing) +pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x + +pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc +pprTyClDeclFlavour (ClassDecl {}) = text "class" +pprTyClDeclFlavour (SynDecl {}) = text "type" +pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = pprFlavour info <+> text "family" +pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x}) + = ppr x +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) + = ppr nd +pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x }) + = ppr x +pprTyClDeclFlavour (XTyClDecl x) = ppr x + + +{- Note [CUSKs: complete user-supplied kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We kind-check declarations differently if they have a complete, user-supplied +kind signature (CUSK). This is because we can safely generalise a CUSKed +declaration before checking all of the others, supporting polymorphic recursion. +See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy +and #9200 for lots of discussion of how we got here. + +The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default. +Under -XNoCUSKs, all declarations are treated as if they have no CUSK. +See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst + +PRINCIPLE: + a type declaration has a CUSK iff we could produce a separate kind signature + for it, just like a type signature for a function, + looking only at the header of the declaration. + +Examples: + * data T1 (a :: *->*) (b :: *) = .... + -- Has CUSK; equivalant to T1 :: (*->*) -> * -> * + + * data T2 a b = ... + -- No CUSK; we do not want to guess T2 :: * -> * -> * + -- because the full decl might be data T a b = MkT (a b) + + * data T3 (a :: k -> *) (b :: *) = ... + -- CUSK; equivalent to T3 :: (k -> *) -> * -> * + -- We lexically generalise over k to get + -- T3 :: forall k. (k -> *) -> * -> * + -- The generalisation is here is purely lexical, just like + -- f3 :: a -> a + -- means + -- f3 :: forall a. a -> a + + * data T4 (a :: j k) = ... + -- CUSK; equivalent to T4 :: j k -> * + -- which we lexically generalise to T4 :: forall j k. j k -> * + -- and then, if PolyKinds is on, we further generalise to + -- T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> * + -- Again this is exactly like what happens as the term level + -- when you write + -- f4 :: forall a b. a b -> Int + +NOTE THAT + * A CUSK does /not/ mean that everything about the kind signature is + fully specified by the user. Look at T4 and f4: we had do do kind + inference to figure out the kind-quantification. But in both cases + (T4 and f4) that inference is done looking /only/ at the header of T4 + (or signature for f4), not at the definition thereof. + + * The CUSK completely fixes the kind of the type constructor, forever. + + * The precise rules, for each declaration form, for whethher a declaration + has a CUSK are given in the user manual section "Complete user-supplied + kind signatures and polymorphic recursion". BUt they simply implement + PRINCIPLE above. + + * Open type families are interesting: + type family T5 a b :: * + There simply /is/ no accompanying declaration, so that info is all + we'll ever get. So we it has a CUSK by definition, and we default + any un-fixed kind variables to *. + + * Associated types are a bit tricker: + class C6 a where + type family T6 a b :: * + op :: a Int -> Int + Here C6 does not have a CUSK (in fact we ultimately discover that + a :: * -> *). And hence neither does T6, the associated family, + because we can't fix its kind until we have settled C6. Another + way to say it: unlike a top-level, we /may/ discover more about + a's kind from C6's definition. + + * A data definition with a top-level :: must explicitly bind all + kind variables to the right of the ::. See test + dependent/should_compile/KindLevels, which requires this + case. (Naturally, any kind variable mentioned before the :: should + not be bound after it.) + + This last point is much more debatable than the others; see + #15142 comment:22 + + Because this is fiddly to check, there is a field in the DataDeclRn + structure (included in a DataDecl after the renamer) that stores whether + or not the declaration has a CUSK. +-} + + +{- ********************************************************************* +* * + TyClGroup + Strongly connected components of + type, class, instance, and role declarations +* * +********************************************************************* -} + +{- Note [TyClGroups and dependency analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TyClGroup represents a strongly connected components of type/class/instance +decls, together with the role annotations for the type/class declarations. + +The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order +sequence of strongly-connected components. + +Invariants + * The type and class declarations, group_tyclds, may depend on each + other, or earlier TyClGroups, but not on later ones + + * The role annotations, group_roles, are role-annotations for some or + all of the types and classes in group_tyclds (only). + + * The instance declarations, group_instds, may (and usually will) + depend on group_tyclds, or on earlier TyClGroups, but not on later + ones. + +See Note [Dependency analsis of type, class, and instance decls] +in RnSource for more info. +-} + +-- | Type or Class Group +data TyClGroup pass -- See Note [TyClGroups and dependency analysis] + = TyClGroup { group_ext :: XCTyClGroup pass + , group_tyclds :: [LTyClDecl pass] + , group_roles :: [LRoleAnnotDecl pass] + , group_instds :: [LInstDecl pass] } + | XTyClGroup (XXTyClGroup pass) + +type instance XCTyClGroup (GhcPass _) = NoExtField +type instance XXTyClGroup (GhcPass _) = NoExtCon + + +tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] +tyClGroupTyClDecls = concatMap group_tyclds + +tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] +tyClGroupInstDecls = concatMap group_instds + +tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] +tyClGroupRoleDecls = concatMap group_roles + + + +{- ********************************************************************* +* * + Data and type family declarations +* * +********************************************************************* -} + +{- Note [FamilyResultSig] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +This data type represents the return signature of a type family. Possible +values are: + + * NoSig - the user supplied no return signature: + type family Id a where ... + + * KindSig - the user supplied the return kind: + type family Id a :: * where ... + + * TyVarSig - user named the result with a type variable and possibly + provided a kind signature for that variable: + type family Id a = r where ... + type family Id a = (r :: *) where ... + + Naming result of a type family is required if we want to provide + injectivity annotation for a type family: + type family Id a = r | r -> a where ... + +See also: Note [Injectivity annotation] + +Note [Injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A user can declare a type family to be injective: + + type family Id a = r | r -> a where ... + + * The part after the "|" is called "injectivity annotation". + * "r -> a" part is called "injectivity condition"; at the moment terms + "injectivity annotation" and "injectivity condition" are synonymous + because we only allow a single injectivity condition. + * "r" is the "LHS of injectivity condition". LHS can only contain the + variable naming the result of a type family. + + * "a" is the "RHS of injectivity condition". RHS contains space-separated + type and kind variables representing the arguments of a type + family. Variables can be omitted if a type family is not injective in + these arguments. Example: + type family Foo a b c = d | d -> a c where ... + +Note that: + (a) naming of type family result is required to provide injectivity + annotation + (b) for associated types if the result was named then injectivity annotation + is mandatory. Otherwise result type variable is indistinguishable from + associated type default. + +It is possible that in the future this syntax will be extended to support +more complicated injectivity annotations. For example we could declare that +if we know the result of Plus and one of its arguments we can determine the +other argument: + + type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ... + +Here injectivity annotation would consist of two comma-separated injectivity +conditions. + +See also Note [Injective type families] in TyCon +-} + +-- | Located type Family Result Signature +type LFamilyResultSig pass = Located (FamilyResultSig pass) + +-- | type Family Result Signature +data FamilyResultSig pass = -- see Note [FamilyResultSig] + NoSig (XNoSig pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + + -- For details on above see note [Api annotations] in ApiAnnotation + + | KindSig (XCKindSig pass) (LHsKind pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnCloseP' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' + | XFamilyResultSig (XXFamilyResultSig pass) + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XNoSig (GhcPass _) = NoExtField +type instance XCKindSig (GhcPass _) = NoExtField +type instance XTyVarSig (GhcPass _) = NoExtField +type instance XXFamilyResultSig (GhcPass _) = NoExtCon + + +-- | Located type Family Declaration +type LFamilyDecl pass = Located (FamilyDecl pass) + +-- | type Family Declaration +data FamilyDecl pass = FamilyDecl + { fdExt :: XCFamilyDecl pass + , fdInfo :: FamilyInfo pass -- type/data, closed/open + , fdLName :: Located (IdP pass) -- type constructor + , fdTyVars :: LHsQTyVars pass -- type variables + -- See Note [TyVar binders for associated declarations] + , fdFixity :: LexicalFixity -- Fixity used in the declaration + , fdResultSig :: LFamilyResultSig pass -- result signature + , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann + } + | XFamilyDecl (XXFamilyDecl pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', + -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', + -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP', + -- 'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow', + -- 'ApiAnnotation.AnnVbar' + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XCFamilyDecl (GhcPass _) = NoExtField +type instance XXFamilyDecl (GhcPass _) = NoExtCon + + +-- | Located Injectivity Annotation +type LInjectivityAnn pass = Located (InjectivityAnn pass) + +-- | If the user supplied an injectivity annotation it is represented using +-- InjectivityAnn. At the moment this is a single injectivity condition - see +-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity +-- condition. `[Located name]` stores the RHS of injectivity condition. Example: +-- +-- type family Foo a b c = r | r -> a c where ... +-- +-- This will be represented as "InjectivityAnn `r` [`a`, `c`]" +data InjectivityAnn pass + = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)] + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' + + -- For details on above see note [Api annotations] in ApiAnnotation + +data FamilyInfo pass + = DataFamily + | OpenTypeFamily + -- | 'Nothing' if we're in an hs-boot file and the user + -- said "type family Foo x where .." + | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) + +-- | Does this family declaration have a complete, user-supplied kind signature? +-- See Note [CUSKs: complete user-supplied kind signatures] +famDeclHasCusk :: Bool -- ^ True <=> the -XCUSKs extension is enabled + -> Bool -- ^ True <=> this is an associated type family, + -- and the parent class has /no/ CUSK + -> FamilyDecl (GhcPass pass) + -> Bool +famDeclHasCusk _cusks_enabled@False _ _ = False +famDeclHasCusk _cusks_enabled@True assoc_with_no_cusk + (FamilyDecl { fdInfo = fam_info + , fdTyVars = tyvars + , fdResultSig = L _ resultSig }) + = case fam_info of + ClosedTypeFamily {} -> hsTvbAllKinded tyvars + && hasReturnKindSignature resultSig + _ -> not assoc_with_no_cusk + -- Un-associated open type/data families have CUSKs + -- Associated type families have CUSKs iff the parent class does + +famDeclHasCusk _ _ (XFamilyDecl nec) = noExtCon nec + +-- | Does this family declaration have user-supplied return kind signature? +hasReturnKindSignature :: FamilyResultSig a -> Bool +hasReturnKindSignature (NoSig _) = False +hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False +hasReturnKindSignature _ = True + +-- | Maybe return name of the result type variable +resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) +resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig +resultVariableName _ = Nothing + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (FamilyDecl p) where + ppr = pprFamilyDecl TopLevel + +pprFamilyDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc +pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L _ result + , fdInjectivityAnn = mb_inj }) + = vcat [ pprFlavour info <+> pp_top_level <+> + pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> + pp_kind <+> pp_inj <+> pp_where + , nest 2 $ pp_eqns ] + where + pp_top_level = case top_level of + TopLevel -> text "family" + NotTopLevel -> empty + + pp_kind = case result of + NoSig _ -> empty + KindSig _ kind -> dcolon <+> ppr kind + TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr + XFamilyResultSig x -> ppr x + pp_inj = case mb_inj of + Just (L _ (InjectivityAnn lhs rhs)) -> + hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] + Nothing -> empty + (pp_where, pp_eqns) = case info of + ClosedTypeFamily mb_eqns -> + ( text "where" + , case mb_eqns of + Nothing -> text ".." + Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) + _ -> (empty, empty) +pprFamilyDecl _ (XFamilyDecl x) = ppr x + +pprFlavour :: FamilyInfo pass -> SDoc +pprFlavour DataFamily = text "data" +pprFlavour OpenTypeFamily = text "type" +pprFlavour (ClosedTypeFamily {}) = text "type" + +instance Outputable (FamilyInfo pass) where + ppr info = pprFlavour info <+> text "family" + + + +{- ********************************************************************* +* * + Data types and data constructors +* * +********************************************************************* -} + +-- | Haskell Data type Definition +data HsDataDefn pass -- The payload of a data type defn + -- Used *both* for vanilla data declarations, + -- *and* for data family instances + = -- | Declares a data type or newtype, giving its constructors + -- @ + -- data/newtype T a = + -- data/newtype instance T [a] = + -- @ + HsDataDefn { dd_ext :: XCHsDataDefn pass, + dd_ND :: NewOrData, + dd_ctxt :: LHsContext pass, -- ^ Context + dd_cType :: Maybe (Located CType), + dd_kindSig:: Maybe (LHsKind pass), + -- ^ Optional kind signature. + -- + -- @(Just k)@ for a GADT-style @data@, + -- or @data instance@ decl, with explicit kind sig + -- + -- Always @Nothing@ for H98-syntax decls + + dd_cons :: [LConDecl pass], + -- ^ Data constructors + -- + -- For @data T a = T1 | T2 a@ + -- the 'LConDecl's all have 'ConDeclH98'. + -- For @data T a where { T1 :: T a }@ + -- the 'LConDecls' all have 'ConDeclGADT'. + + dd_derivs :: HsDeriving pass -- ^ Optional 'deriving' claues + + -- For details on above see note [Api annotations] in ApiAnnotation + } + | XHsDataDefn (XXHsDataDefn pass) + +type instance XCHsDataDefn (GhcPass _) = NoExtField +type instance XXHsDataDefn (GhcPass _) = NoExtCon + +-- | Haskell Deriving clause +type HsDeriving pass = Located [LHsDerivingClause pass] + -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is + -- plural because one can specify multiple deriving clauses using the + -- @-XDerivingStrategies@ language extension. + -- + -- The list of 'LHsDerivingClause's corresponds to exactly what the user + -- requested to derive, in order. If no deriving clauses were specified, + -- the list is empty. + +type LHsDerivingClause pass = Located (HsDerivingClause pass) + +-- | A single @deriving@ clause of a data declaration. +-- +-- - 'ApiAnnotation.AnnKeywordId' : +-- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock', +-- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', +-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' +data HsDerivingClause pass + -- See Note [Deriving strategies] in TcDeriv + = HsDerivingClause + { deriv_clause_ext :: XCHsDerivingClause pass + , deriv_clause_strategy :: Maybe (LDerivStrategy pass) + -- ^ The user-specified strategy (if any) to use when deriving + -- 'deriv_clause_tys'. + , deriv_clause_tys :: Located [LHsSigType pass] + -- ^ The types to derive. + -- + -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, + -- we can mention type variables that aren't bound by the datatype, e.g. + -- + -- > data T b = ... deriving (C [a]) + -- + -- should produce a derived instance for @C [a] (T b)@. + } + | XHsDerivingClause (XXHsDerivingClause pass) + +type instance XCHsDerivingClause (GhcPass _) = NoExtField +type instance XXHsDerivingClause (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsDerivingClause p) where + ppr (HsDerivingClause { deriv_clause_strategy = dcs + , deriv_clause_tys = L _ dct }) + = hsep [ text "deriving" + , pp_strat_before + , pp_dct dct + , pp_strat_after ] + where + -- This complexity is to distinguish between + -- deriving Show + -- deriving (Show) + pp_dct [HsIB { hsib_body = ty }] + = ppr (parenthesizeHsType appPrec ty) + pp_dct _ = parens (interpp'SP dct) + + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case dcs of + Just (L _ via@ViaStrategy{}) -> (empty, ppr via) + _ -> (ppDerivStrategy dcs, empty) + ppr (XHsDerivingClause x) = ppr x + +data NewOrData + = NewType -- ^ @newtype Blah ...@ + | DataType -- ^ @data Blah ...@ + deriving( Eq, Data ) -- Needed because Demand derives Eq + +-- | Convert a 'NewOrData' to a 'TyConFlavour' +newOrDataToFlavour :: NewOrData -> TyConFlavour +newOrDataToFlavour NewType = NewtypeFlavour +newOrDataToFlavour DataType = DataTypeFlavour + +-- | Located data Constructor Declaration +type LConDecl pass = Located (ConDecl pass) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when + -- in a GADT constructor list + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | +-- +-- @ +-- data T b = forall a. Eq a => MkT a b +-- MkT :: forall b a. Eq a => MkT a b +-- +-- data T b where +-- MkT1 :: Int -> T Int +-- +-- data T = Int `MkT` Int +-- | MkT2 +-- +-- data T a where +-- Int `MkT` Int :: T Int +-- @ +-- +-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow', +-- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot' + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | data Constructor Declaration +data ConDecl pass + = ConDeclGADT + { con_g_ext :: XConDeclGADT pass + , con_names :: [Located (IdP pass)] + + -- The next four fields describe the type after the '::' + -- See Note [GADT abstract syntax] + -- The following field is Located to anchor API Annotations, + -- AnnForall and AnnDot. + , con_forall :: Located Bool -- ^ True <=> explicit forall + -- False => hsq_explicit is empty + , con_qvars :: LHsQTyVars pass + -- Whether or not there is an /explicit/ forall, we still + -- need to capture the implicitly-bound type/kind variables + + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon + , con_res_ty :: LHsType pass -- ^ Result type + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } + + | ConDeclH98 + { con_ext :: XConDeclH98 pass + , con_name :: Located (IdP pass) + + , con_forall :: Located Bool + -- ^ True <=> explicit user-written forall + -- e.g. data T a = forall b. MkT b (b->a) + -- con_ex_tvs = {b} + -- False => con_ex_tvs is empty + , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } + | XConDecl (XXConDecl pass) + +type instance XConDeclGADT (GhcPass _) = NoExtField +type instance XConDeclH98 (GhcPass _) = NoExtField +type instance XXConDecl (GhcPass _) = NoExtCon + +{- Note [GADT abstract syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a wrinkle in ConDeclGADT + +* For record syntax, it's all uniform. Given: + data T a where + K :: forall a. Ord a => { x :: [a], ... } -> T a + we make the a ConDeclGADT for K with + con_qvars = {a} + con_mb_cxt = Just [Ord a] + con_args = RecCon + con_res_ty = T a + + We need the RecCon before the reanmer, so we can find the record field + binders in GHC.Hs.Utils.hsConDeclsBinders. + +* However for a GADT constr declaration which is not a record, it can + be hard parse until we know operator fixities. Consider for example + C :: a :*: b -> a :*: b -> a :+: b + Initially this type will parse as + a :*: (b -> (a :*: (b -> (a :+: b)))) + so it's hard to split up the arguments until we've done the precedence + resolution (in the renamer). + + So: - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr + type into the res_ty for a ConDeclGADT for now, and use + PrefixCon [] + con_args = PrefixCon [] + con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) + + - In the renamer (RnSource.rnConDecl), we unravel it afer + operator fixities are sorted. So we generate. So we end + up with + con_args = PrefixCon [ a :*: b, a :*: b ] + con_res_ty = a :+: b +-} + +-- | Haskell data Constructor Declaration Details +type HsConDeclDetails pass + = HsConDetails (LBangType pass) (Located [LConDeclField pass]) + +getConNames :: ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))] +getConNames ConDeclH98 {con_name = name} = [name] +getConNames ConDeclGADT {con_names = names} = names +getConNames (XConDecl nec) = noExtCon nec + +getConArgs :: ConDecl pass -> HsConDeclDetails pass +getConArgs d = con_args d + +hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] +hsConDeclArgTys (PrefixCon tys) = tys +hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] +hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) + +hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] +hsConDeclTheta Nothing = [] +hsConDeclTheta (Just (L _ theta)) = theta + +pp_data_defn :: (OutputableBndrId (GhcPass p)) + => (LHsContext (GhcPass p) -> SDoc) -- Printing the header + -> HsDataDefn (GhcPass p) + -> SDoc +pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls, dd_derivs = derivings }) + | null condecls + = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig + <+> pp_derivings derivings + + | otherwise + = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) + 2 (pp_condecls condecls $$ pp_derivings derivings) + where + pp_ct = case mb_ct of + Nothing -> empty + Just ct -> ppr ct + pp_sig = case mb_sig of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + pp_derivings (L _ ds) = vcat (map ppr ds) +pp_data_defn _ (XHsDataDefn x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsDataDefn p) where + ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d + +instance Outputable NewOrData where + ppr NewType = text "newtype" + ppr DataType = text "data" + +pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc +pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax + = hang (text "where") 2 (vcat (map ppr cs)) +pp_condecls cs -- In H98 syntax + = equals <+> sep (punctuate (text " |") (map ppr cs)) + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where + ppr = pprConDecl + +pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> SDoc +pprConDecl (ConDeclH98 { con_name = L _ con + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_doc = doc }) + = sep [ppr_mbDoc doc, pprHsForAll ForallInvis ex_tvs cxt, ppr_details args] + where + ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con + : map (pprHsType . unLoc) tys) + ppr_details (RecCon fields) = pprPrefixOcc con + <+> pprConDeclFields (unLoc fields) + cxt = fromMaybe noLHsContext mcxt + +pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty, con_doc = doc }) + = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon + <+> (sep [pprHsForAll ForallInvis (hsq_explicit qvars) cxt, + ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) + where + get_args (PrefixCon args) = map ppr args + get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] + get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) + + cxt = fromMaybe noLHsContext mcxt + + ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) + ppr_arrow_chain [] = empty + +pprConDecl (XConDecl x) = ppr x + +ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc +ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) + +{- +************************************************************************ +* * + Instance declarations +* * +************************************************************************ + +Note [Type family instance declarations in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The data type FamEqn represents one equation of a type family instance. +Aside from the pass, it is also parameterised over another field, feqn_rhs. +feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType +(for type family instances). + +Type family instances also include associated type family default equations. +That is because a default for a type family looks like this: + + class C a where + type family F a b :: Type + type F c d = (c,d) -- Default instance + +The default declaration is really just a `type instance` declaration, but one +with particularly simple patterns: they must all be distinct type variables. +That's because we will instantiate it (in an instance declaration for `C`) if +we don't give an explicit instance for `F`. Note that the names of the +variables don't need to match those of the class: it really is like a +free-standing `type instance` declaration. +-} + +----------------- Type synonym family instances ------------- + +-- | Located Type Family Instance Equation +type LTyFamInstEqn pass = Located (TyFamInstEqn pass) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- when in a list + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Haskell Type Patterns +type HsTyPats pass = [LHsTypeArg pass] + +{- Note [Family instance declaration binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The feqn_pats field of FamEqn (family instance equation) stores the LHS type +(and kind) patterns. Any type (and kind) variables contained +in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs +in FamInstEqn depending on whether or not an explicit forall is present. In +the case of an explicit forall, the hsib_vars only includes kind variables not +bound in the forall. Otherwise, all type (and kind) variables are bound in +the hsib_vars. In the latter case, note that in particular + +* The hsib_vars *includes* any anonymous wildcards. For example + type instance F a _ = a + The hsib_vars will be {a, _}. Remember that each separate wildcard + '_' gets its own unique. In this context wildcards behave just like + an ordinary type variable, only anonymous. + +* The hsib_vars *includes* type variables that are already in scope + + Eg class C s t where + type F t p :: * + instance C w (a,b) where + type F (a,b) x = x->a + The hsib_vars of the F decl are {a,b,x}, even though the F decl + is nested inside the 'instance' decl. + + However after the renamer, the uniques will match up: + instance C w7 (a8,b9) where + type F (a8,b9) x10 = x10->a8 + so that we can compare the type pattern in the 'instance' decl and + in the associated 'type' decl + +c.f. Note [TyVar binders for associated decls] +-} + +-- | Type Family Instance Equation +type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) + +-- | Type family default declarations. +-- A convenient synonym for 'TyFamInstDecl'. +-- See @Note [Type family instance declarations in HsSyn]@. +type TyFamDefltDecl = TyFamInstDecl + +-- | Located type family default declarations. +type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass) + +-- | Located Type Family Instance Declaration +type LTyFamInstDecl pass = Located (TyFamInstDecl pass) + +-- | Type Family Instance Declaration +newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnInstance', + + -- For details on above see note [Api annotations] in ApiAnnotation + +----------------- Data family instances ------------- + +-- | Located Data Family Instance Declaration +type LDataFamInstDecl pass = Located (DataFamInstDecl pass) + +-- | Data Family Instance Declaration +newtype DataFamInstDecl pass + = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', + -- 'ApiAnnotation.AnnDcolon' + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + +----------------- Family instances (common types) ------------- + +-- | Located Family Instance Equation +type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs) + +-- | Family Instance Equation +type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs) + -- ^ Here, the @pats@ are type patterns (with kind and type bndrs). + -- See Note [Family instance declaration binders] + +-- | Family Equation +-- +-- One equation in a type family instance declaration, data family instance +-- declaration, or type family default. +-- See Note [Type family instance declarations in HsSyn] +-- See Note [Family instance declaration binders] +data FamEqn pass rhs + = FamEqn + { feqn_ext :: XCFamEqn pass rhs + , feqn_tycon :: Located (IdP pass) + , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars + , feqn_pats :: HsTyPats pass + , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration + , feqn_rhs :: rhs + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + | XFamEqn (XXFamEqn pass rhs) + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XCFamEqn (GhcPass _) r = NoExtField +type instance XXFamEqn (GhcPass _) r = NoExtCon + +----------------- Class instances ------------- + +-- | Located Class Instance Declaration +type LClsInstDecl pass = Located (ClsInstDecl pass) + +-- | Class Instance Declaration +data ClsInstDecl pass + = ClsInstDecl + { cid_ext :: XCClsInstDecl pass + , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + , cid_binds :: LHsBinds pass -- Class methods + , cid_sigs :: [LSig pass] -- User-supplied pragmatic info + , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances + , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances + , cid_overlap_mode :: Maybe (Located OverlapMode) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance', + -- 'ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | XClsInstDecl (XXClsInstDecl pass) + +type instance XCClsInstDecl (GhcPass _) = NoExtField +type instance XXClsInstDecl (GhcPass _) = NoExtCon + +----------------- Instances of all kinds ------------- + +-- | Located Instance Declaration +type LInstDecl pass = Located (InstDecl pass) + +-- | Instance Declaration +data InstDecl pass -- Both class and family instances + = ClsInstD + { cid_d_ext :: XClsInstD pass + , cid_inst :: ClsInstDecl pass } + | DataFamInstD -- data family instance + { dfid_ext :: XDataFamInstD pass + , dfid_inst :: DataFamInstDecl pass } + | TyFamInstD -- type family instance + { tfid_ext :: XTyFamInstD pass + , tfid_inst :: TyFamInstDecl pass } + | XInstDecl (XXInstDecl pass) + +type instance XClsInstD (GhcPass _) = NoExtField +type instance XDataFamInstD (GhcPass _) = NoExtField +type instance XTyFamInstD (GhcPass _) = NoExtField +type instance XXInstDecl (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (TyFamInstDecl p) where + ppr = pprTyFamInstDecl TopLevel + +pprTyFamInstDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc +pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) + = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn + +ppr_instance_keyword :: TopLevelFlag -> SDoc +ppr_instance_keyword TopLevel = text "instance" +ppr_instance_keyword NotTopLevel = empty + +pprTyFamDefltDecl :: (OutputableBndrId (GhcPass p)) + => TyFamDefltDecl (GhcPass p) -> SDoc +pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel + +ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p)) + => TyFamInstEqn (GhcPass p) -> SDoc +ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = rhs }}) + = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs +ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x +ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DataFamInstDecl p) where + ppr = pprDataFamInstDecl TopLevel + +pprDataFamInstDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L _ tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn }}}) + = pp_data_defn pp_hdr defn + where + pp_hdr ctxt = ppr_instance_keyword top_lvl + <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt + -- pp_data_defn pretty-prints the kind sig. See #14817. + +pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x))) + = ppr x +pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x)) + = ppr x + +pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) + = ppr nd +pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = XHsDataDefn x}}}) + = ppr x +pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) + = ppr x +pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) + = ppr x + +pprHsFamInstLHS :: (OutputableBndrId (GhcPass p)) + => IdP (GhcPass p) + -> Maybe [LHsTyVarBndr (GhcPass p)] + -> HsTyPats (GhcPass p) + -> LexicalFixity + -> LHsContext (GhcPass p) + -> SDoc +pprHsFamInstLHS thing bndrs typats fixity mb_ctxt + = hsep [ pprHsExplicitForAll ForallInvis bndrs + , pprLHsContext mb_ctxt + , pp_pats typats ] + where + pp_pats (patl:patr:pats) + | Infix <- fixity + = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in + case pats of + [] -> pp_op_app + _ -> hsep (parens pp_op_app : map ppr pats) + + pp_pats pats = hsep [ pprPrefixOcc thing + , hsep (map ppr pats)] + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ClsInstDecl p) where + ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part + = top_matter + + | otherwise -- Laid out + = vcat [ top_matter <+> text "where" + , nest 2 $ pprDeclList $ + map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ + map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ + pprLHsBindsForUser binds sigs ] + where + top_matter = text "instance" <+> ppOverlapPragma mbOverlap + <+> ppr inst_ty + ppr (XClsInstDecl x) = ppr x + +ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p) + => Maybe (LDerivStrategy p) -> SDoc +ppDerivStrategy mb = + case mb of + Nothing -> empty + Just (L _ ds) -> ppr ds + +ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc +ppOverlapPragma mb = + case mb of + Nothing -> empty + Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" + Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" + Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" + Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" + Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" + where + maybe_stext NoSourceText alt = text alt + maybe_stext (SourceText src) _ = text src <+> text "#-}" + + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where + ppr (ClsInstD { cid_inst = decl }) = ppr decl + ppr (TyFamInstD { tfid_inst = decl }) = ppr decl + ppr (DataFamInstD { dfid_inst = decl }) = ppr decl + ppr (XInstDecl x) = ppr x + +-- Extract the declarations of associated data types from an instance + +instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)] +instDeclDataFamInsts inst_decls + = concatMap do_one inst_decls + where + do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) + = map unLoc fam_insts + do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] + do_one (L _ (TyFamInstD {})) = [] + do_one (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec + do_one (L _ (XInstDecl nec)) = noExtCon nec + +{- +************************************************************************ +* * +\subsection[DerivDecl]{A stand-alone instance deriving declaration} +* * +************************************************************************ +-} + +-- | Located stand-alone 'deriving instance' declaration +type LDerivDecl pass = Located (DerivDecl pass) + +-- | Stand-alone 'deriving instance' declaration +data DerivDecl pass = DerivDecl + { deriv_ext :: XCDerivDecl pass + , deriv_type :: LHsSigWcType pass + -- ^ The instance type to derive. + -- + -- It uses an 'LHsSigWcType' because the context is allowed to be a + -- single wildcard: + -- + -- > deriving instance _ => Eq (Foo a) + -- + -- Which signifies that the context should be inferred. + + -- See Note [Inferring the instance context] in TcDerivInfer. + + , deriv_strategy :: Maybe (LDerivStrategy pass) + , deriv_overlap_mode :: Maybe (Located OverlapMode) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', + -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', + -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + } + | XDerivDecl (XXDerivDecl pass) + +type instance XCDerivDecl (GhcPass _) = NoExtField +type instance XXDerivDecl (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DerivDecl p) where + ppr (DerivDecl { deriv_type = ty + , deriv_strategy = ds + , deriv_overlap_mode = o }) + = hsep [ text "deriving" + , ppDerivStrategy ds + , text "instance" + , ppOverlapPragma o + , ppr ty ] + ppr (XDerivDecl x) = ppr x + +{- +************************************************************************ +* * + Deriving strategies +* * +************************************************************************ +-} + +-- | A 'Located' 'DerivStrategy'. +type LDerivStrategy pass = Located (DerivStrategy pass) + +-- | Which technique the user explicitly requested when deriving an instance. +data DerivStrategy pass + -- See Note [Deriving strategies] in TcDeriv + = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a + -- custom instance for the data type. This only works + -- for certain types that GHC knows about (e.g., 'Eq', + -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, + -- etc.) + | AnyclassStrategy -- ^ @-XDeriveAnyClass@ + | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy (XViaStrategy pass) + -- ^ @-XDerivingVia@ + +type instance XViaStrategy GhcPs = LHsSigType GhcPs +type instance XViaStrategy GhcRn = LHsSigType GhcRn +type instance XViaStrategy GhcTc = Type + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DerivStrategy p) where + ppr StockStrategy = text "stock" + ppr AnyclassStrategy = text "anyclass" + ppr NewtypeStrategy = text "newtype" + ppr (ViaStrategy ty) = text "via" <+> ppr ty + +-- | A short description of a @DerivStrategy'@. +derivStrategyName :: DerivStrategy a -> SDoc +derivStrategyName = text . go + where + go StockStrategy = "stock" + go AnyclassStrategy = "anyclass" + go NewtypeStrategy = "newtype" + go (ViaStrategy {}) = "via" + +-- | Eliminate a 'DerivStrategy'. +foldDerivStrategy :: (p ~ GhcPass pass) + => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r +foldDerivStrategy other _ StockStrategy = other +foldDerivStrategy other _ AnyclassStrategy = other +foldDerivStrategy other _ NewtypeStrategy = other +foldDerivStrategy _ via (ViaStrategy t) = via t + +-- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise, +-- return the 'DerivStrategy' unchanged. +mapDerivStrategy :: (p ~ GhcPass pass) + => (XViaStrategy p -> XViaStrategy p) + -> DerivStrategy p -> DerivStrategy p +mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds + +{- +************************************************************************ +* * +\subsection[DefaultDecl]{A @default@ declaration} +* * +************************************************************************ + +There can only be one default declaration per module, but it is hard +for the parser to check that; we pass them all through in the abstract +syntax, and that restriction must be checked in the front end. +-} + +-- | Located Default Declaration +type LDefaultDecl pass = Located (DefaultDecl pass) + +-- | Default Declaration +data DefaultDecl pass + = DefaultDecl (XCDefaultDecl pass) [LHsType pass] + -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XDefaultDecl (XXDefaultDecl pass) + +type instance XCDefaultDecl (GhcPass _) = NoExtField +type instance XXDefaultDecl (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DefaultDecl p) where + ppr (DefaultDecl _ tys) + = text "default" <+> parens (interpp'SP tys) + ppr (XDefaultDecl x) = ppr x + +{- +************************************************************************ +* * +\subsection{Foreign function interface declaration} +* * +************************************************************************ +-} + +-- foreign declarations are distinguished as to whether they define or use a +-- Haskell name +-- +-- * the Boolean value indicates whether the pre-standard deprecated syntax +-- has been used + +-- | Located Foreign Declaration +type LForeignDecl pass = Located (ForeignDecl pass) + +-- | Foreign Declaration +data ForeignDecl pass + = ForeignImport + { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: Located (IdP pass) -- defines this name + , fd_sig_ty :: LHsSigType pass -- sig_ty + , fd_fi :: ForeignImport } + + | ForeignExport + { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: Located (IdP pass) -- uses this name + , fd_sig_ty :: LHsSigType pass -- sig_ty + , fd_fe :: ForeignExport } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', + -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', + -- 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XForeignDecl (XXForeignDecl pass) + +{- + In both ForeignImport and ForeignExport: + sig_ty is the type given in the Haskell code + rep_ty is the representation for this type, i.e. with newtypes + coerced away and type functions evaluated. + Thus if the declaration is valid, then rep_ty will only use types + such as Int and IO that we know how to make foreign calls with. +-} + +type instance XForeignImport GhcPs = NoExtField +type instance XForeignImport GhcRn = NoExtField +type instance XForeignImport GhcTc = Coercion + +type instance XForeignExport GhcPs = NoExtField +type instance XForeignExport GhcRn = NoExtField +type instance XForeignExport GhcTc = Coercion + +type instance XXForeignDecl (GhcPass _) = NoExtCon + +-- Specification Of an imported external entity in dependence on the calling +-- convention +-- +data ForeignImport = -- import of a C entity + -- + -- * the two strings specifying a header file or library + -- may be empty, which indicates the absence of a + -- header or object specification (both are not used + -- in the case of `CWrapper' and when `CFunction' + -- has a dynamic target) + -- + -- * the calling convention is irrelevant for code + -- generation in the case of `CLabel', but is needed + -- for pretty printing + -- + -- * `Safety' is irrelevant for `CLabel' and `CWrapper' + -- + CImport (Located CCallConv) -- ccall or stdcall + (Located Safety) -- interruptible, safe or unsafe + (Maybe Header) -- name of C header + CImportSpec -- details of the C entity + (Located SourceText) -- original source text for + -- the C entity + deriving Data + +-- details of an external C entity +-- +data CImportSpec = CLabel CLabelString -- import address of a C label + | CFunction CCallTarget -- static or dynamic function + | CWrapper -- wrapper to expose closures + -- (former f.e.d.) + deriving Data + +-- specification of an externally exported entity in dependence on the calling +-- convention +-- +data ForeignExport = CExport (Located CExportSpec) -- contains the calling + -- convention + (Located SourceText) -- original source text for + -- the C entity + deriving Data + +-- pretty printing of foreign declarations +-- + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ForeignDecl p) where + ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) + = hang (text "foreign import" <+> ppr fimport <+> ppr n) + 2 (dcolon <+> ppr ty) + ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = + hang (text "foreign export" <+> ppr fexport <+> ppr n) + 2 (dcolon <+> ppr ty) + ppr (XForeignDecl x) = ppr x + +instance Outputable ForeignImport where + ppr (CImport cconv safety mHeader spec (L _ srcText)) = + ppr cconv <+> ppr safety + <+> pprWithSourceText srcText (pprCEntity spec "") + where + pp_hdr = case mHeader of + Nothing -> empty + Just (Header _ header) -> ftext header + + pprCEntity (CLabel lbl) _ = + doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl + pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = + if dqNeeded then doubleQuotes ce else empty + where + dqNeeded = (take 6 src == "static") + || isJust mHeader + || not isFun + || st /= NoSourceText + ce = + -- We may need to drop leading spaces first + (if take 6 src == "static" then text "static" else empty) + <+> pp_hdr + <+> (if isFun then empty else text "value") + <+> (pprWithSourceText st empty) + pprCEntity (CFunction DynamicTarget) _ = + doubleQuotes $ text "dynamic" + pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" + +instance Outputable ForeignExport where + ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = + ppr cconv <+> char '"' <> ppr lbl <> char '"' + +{- +************************************************************************ +* * +\subsection{Transformation rules} +* * +************************************************************************ +-} + +-- | Located Rule Declarations +type LRuleDecls pass = Located (RuleDecls pass) + + -- Note [Pragma source text] in BasicTypes +-- | Rule Declarations +data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass + , rds_src :: SourceText + , rds_rules :: [LRuleDecl pass] } + | XRuleDecls (XXRuleDecls pass) + +type instance XCRuleDecls (GhcPass _) = NoExtField +type instance XXRuleDecls (GhcPass _) = NoExtCon + +-- | Located Rule Declaration +type LRuleDecl pass = Located (RuleDecl pass) + +-- | Rule Declaration +data RuleDecl pass + = HsRule -- Source rule + { rd_ext :: XHsRule pass + -- ^ After renamer, free-vars from the LHS and RHS + , rd_name :: Located (SourceText,RuleName) + -- ^ Note [Pragma source text] in BasicTypes + , rd_act :: Activation + , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] + -- ^ Forall'd type vars + , rd_tmvs :: [LRuleBndr pass] + -- ^ Forall'd term vars, before typechecking; after typechecking + -- this includes all forall'd vars + , rd_lhs :: Located (HsExpr pass) + , rd_rhs :: Located (HsExpr pass) + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', + -- 'ApiAnnotation.AnnEqual', + | XRuleDecl (XXRuleDecl pass) + +data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + deriving Data + +type instance XHsRule GhcPs = NoExtField +type instance XHsRule GhcRn = HsRuleRn +type instance XHsRule GhcTc = HsRuleRn + +type instance XXRuleDecl (GhcPass _) = NoExtCon + +flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] +flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls + +-- | Located Rule Binder +type LRuleBndr pass = Located (RuleBndr pass) + +-- | Rule Binder +data RuleBndr pass + = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) + | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass) + | XRuleBndr (XXRuleBndr pass) + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XCRuleBndr (GhcPass _) = NoExtField +type instance XRuleBndrSig (GhcPass _) = NoExtField +type instance XXRuleBndr (GhcPass _) = NoExtCon + +collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] +collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] + +pprFullRuleName :: Located (SourceText, RuleName) -> SDoc +pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecls p) where + ppr (HsRules { rds_src = st + , rds_rules = rules }) + = pprWithSourceText st (text "{-# RULES") + <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" + ppr (XRuleDecls x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where + ppr (HsRule { rd_name = name + , rd_act = act + , rd_tyvs = tys + , rd_tmvs = tms + , rd_lhs = lhs + , rd_rhs = rhs }) + = sep [pprFullRuleName name <+> ppr act, + nest 4 (pp_forall_ty tys <+> pp_forall_tm tys + <+> pprExpr (unLoc lhs)), + nest 6 (equals <+> pprExpr (unLoc rhs)) ] + where + pp_forall_ty Nothing = empty + pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot + pp_forall_tm Nothing | null tms = empty + pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot + ppr (XRuleDecl x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where + ppr (RuleBndr _ name) = ppr name + ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) + ppr (XRuleBndr x) = ppr x + +{- +************************************************************************ +* * +\subsection[DocDecl]{Document comments} +* * +************************************************************************ +-} + +-- | Located Documentation comment Declaration +type LDocDecl = Located (DocDecl) + +-- | Documentation comment Declaration +data DocDecl + = DocCommentNext HsDocString + | DocCommentPrev HsDocString + | DocCommentNamed String HsDocString + | DocGroup Int HsDocString + deriving Data + +-- Okay, I need to reconstruct the document comments, but for now: +instance Outputable DocDecl where + ppr _ = text "" + +docDeclDoc :: DocDecl -> HsDocString +docDeclDoc (DocCommentNext d) = d +docDeclDoc (DocCommentPrev d) = d +docDeclDoc (DocCommentNamed _ d) = d +docDeclDoc (DocGroup _ d) = d + +{- +************************************************************************ +* * +\subsection[DeprecDecl]{Deprecations} +* * +************************************************************************ + +We use exported entities for things to deprecate. +-} + +-- | Located Warning Declarations +type LWarnDecls pass = Located (WarnDecls pass) + + -- Note [Pragma source text] in BasicTypes +-- | Warning pragma Declarations +data WarnDecls pass = Warnings { wd_ext :: XWarnings pass + , wd_src :: SourceText + , wd_warnings :: [LWarnDecl pass] + } + | XWarnDecls (XXWarnDecls pass) + +type instance XWarnings (GhcPass _) = NoExtField +type instance XXWarnDecls (GhcPass _) = NoExtCon + +-- | Located Warning pragma Declaration +type LWarnDecl pass = Located (WarnDecl pass) + +-- | Warning pragma Declaration +data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt + | XWarnDecl (XXWarnDecl pass) + +type instance XWarning (GhcPass _) = NoExtField +type instance XXWarnDecl (GhcPass _) = NoExtCon + + +instance (p ~ GhcPass pass,OutputableBndr (IdP p)) + => Outputable (WarnDecls p) where + ppr (Warnings _ (SourceText src) decls) + = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" + ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" + ppr (XWarnDecls x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndr (IdP p)) + => Outputable (WarnDecl p) where + ppr (Warning _ thing txt) + = hsep ( punctuate comma (map ppr thing)) + <+> ppr txt + ppr (XWarnDecl x) = ppr x + +{- +************************************************************************ +* * +\subsection[AnnDecl]{Annotations} +* * +************************************************************************ +-} + +-- | Located Annotation Declaration +type LAnnDecl pass = Located (AnnDecl pass) + +-- | Annotation Declaration +data AnnDecl pass = HsAnnotation + (XHsAnnotation pass) + SourceText -- Note [Pragma source text] in BasicTypes + (AnnProvenance (IdP pass)) (Located (HsExpr pass)) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnType' + -- 'ApiAnnotation.AnnModule' + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XAnnDecl (XXAnnDecl pass) + +type instance XHsAnnotation (GhcPass _) = NoExtField +type instance XXAnnDecl (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where + ppr (HsAnnotation _ _ provenance expr) + = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] + ppr (XAnnDecl x) = ppr x + +-- | Annotation Provenance +data AnnProvenance name = ValueAnnProvenance (Located name) + | TypeAnnProvenance (Located name) + | ModuleAnnProvenance +deriving instance Functor AnnProvenance +deriving instance Foldable AnnProvenance +deriving instance Traversable AnnProvenance +deriving instance (Data pass) => Data (AnnProvenance pass) + +annProvenanceName_maybe :: AnnProvenance name -> Maybe name +annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe ModuleAnnProvenance = Nothing + +pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc +pprAnnProvenance ModuleAnnProvenance = text "ANN module" +pprAnnProvenance (ValueAnnProvenance (L _ name)) + = text "ANN" <+> ppr name +pprAnnProvenance (TypeAnnProvenance (L _ name)) + = text "ANN type" <+> ppr name + +{- +************************************************************************ +* * +\subsection[RoleAnnot]{Role annotations} +* * +************************************************************************ +-} + +-- | Located Role Annotation Declaration +type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass) + +-- See #8185 for more info about why role annotations are +-- top-level declarations +-- | Role Annotation Declaration +data RoleAnnotDecl pass + = RoleAnnotDecl (XCRoleAnnotDecl pass) + (Located (IdP pass)) -- type constructor + [Located (Maybe Role)] -- optional annotations + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnRole' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XRoleAnnotDecl (XXRoleAnnotDecl pass) + +type instance XCRoleAnnotDecl (GhcPass _) = NoExtField +type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndr (IdP p)) + => Outputable (RoleAnnotDecl p) where + ppr (RoleAnnotDecl _ ltycon roles) + = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+> + hsep (map (pp_role . unLoc) roles) + where + pp_role Nothing = underscore + pp_role (Just r) = ppr r + ppr (XRoleAnnotDecl x) = ppr x + +roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p) +roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name +roleAnnotDeclName (XRoleAnnotDecl nec) = noExtCon nec diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs new file mode 100644 index 0000000000..18a820fa6e --- /dev/null +++ b/compiler/GHC/Hs/Doc.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Hs.Doc + ( HsDocString + , LHsDocString + , mkHsDocString + , mkHsDocStringUtf8ByteString + , unpackHDS + , hsDocStringToByteString + , ppr_mbDoc + + , appendDocs + , concatDocs + + , DeclDocMap(..) + , emptyDeclDocMap + + , ArgDocMap(..) + , emptyArgDocMap + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Binary +import Encoding +import FastFunctions +import Name +import Outputable +import SrcLoc + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Internal as BS +import Data.Data +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Foreign + +-- | Haskell Documentation String +-- +-- Internally this is a UTF8-Encoded 'ByteString'. +newtype HsDocString = HsDocString ByteString + -- There are at least two plausible Semigroup instances for this type: + -- + -- 1. Simple string concatenation. + -- 2. Concatenation as documentation paragraphs with newlines in between. + -- + -- To avoid confusion, we pass on defining an instance at all. + deriving (Eq, Show, Data) + +-- | Located Haskell Documentation String +type LHsDocString = Located HsDocString + +instance Binary HsDocString where + put_ bh (HsDocString bs) = put_ bh bs + get bh = HsDocString <$> get bh + +instance Outputable HsDocString where + ppr = doubleQuotes . text . unpackHDS + +mkHsDocString :: String -> HsDocString +mkHsDocString s = + inlinePerformIO $ do + let len = utf8EncodedLength s + buf <- mallocForeignPtrBytes len + withForeignPtr buf $ \ptr -> do + utf8EncodeString ptr s + pure (HsDocString (BS.fromForeignPtr buf 0 len)) + +-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. +mkHsDocStringUtf8ByteString :: ByteString -> HsDocString +mkHsDocStringUtf8ByteString = HsDocString + +unpackHDS :: HsDocString -> String +unpackHDS = utf8DecodeByteString . hsDocStringToByteString + +-- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'. +hsDocStringToByteString :: HsDocString -> ByteString +hsDocStringToByteString (HsDocString bs) = bs + +ppr_mbDoc :: Maybe LHsDocString -> SDoc +ppr_mbDoc (Just doc) = ppr doc +ppr_mbDoc Nothing = empty + +-- | Join two docstrings. +-- +-- Non-empty docstrings are joined with two newlines in between, +-- resulting in separate paragraphs. +appendDocs :: HsDocString -> HsDocString -> HsDocString +appendDocs x y = + fromMaybe + (HsDocString BS.empty) + (concatDocs [x, y]) + +-- | Concat docstrings with two newlines in between. +-- +-- Empty docstrings are skipped. +-- +-- If all inputs are empty, 'Nothing' is returned. +concatDocs :: [HsDocString] -> Maybe HsDocString +concatDocs xs = + if BS.null b + then Nothing + else Just (HsDocString b) + where + b = BS.intercalate (C8.pack "\n\n") + . filter (not . BS.null) + . map hsDocStringToByteString + $ xs + +-- | Docs for declarations: functions, data types, instances, methods etc. +newtype DeclDocMap = DeclDocMap (Map Name HsDocString) + +instance Binary DeclDocMap where + put_ bh (DeclDocMap m) = put_ bh (Map.toList m) + -- We can't rely on a deterministic ordering of the `Name`s here. + -- See the comments on `Name`'s `Ord` instance for context. + get bh = DeclDocMap . Map.fromList <$> get bh + +instance Outputable DeclDocMap where + ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m)) + where + pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc) + +emptyDeclDocMap :: DeclDocMap +emptyDeclDocMap = DeclDocMap Map.empty + +-- | Docs for arguments. E.g. function arguments, method arguments. +newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString)) + +instance Binary ArgDocMap where + put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m)) + -- We can't rely on a deterministic ordering of the `Name`s here. + -- See the comments on `Name`'s `Ord` instance for context. + get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh + +instance Outputable ArgDocMap where + ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) + where + pprPair (name, int_map) = + ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map) + pprIntMap im = vcat (map pprIPair (Map.toAscList im)) + pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) + +emptyArgDocMap :: ArgDocMap +emptyArgDocMap = ArgDocMap Map.empty diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs new file mode 100644 index 0000000000..5bdfc8668e --- /dev/null +++ b/compiler/GHC/Hs/Dump.hs @@ -0,0 +1,220 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb +-- traversal which falls back to displaying based on the constructor name, so +-- can be used to dump anything having a @Data.Data@ instance. + +module GHC.Hs.Dump ( + -- * Dumping ASTs + showAstData, + BlankSrcSpan(..), + ) where + +import GhcPrelude + +import Data.Data hiding (Fixity) +import Bag +import BasicTypes +import FastString +import NameSet +import Name +import DataCon +import SrcLoc +import GHC.Hs +import OccName hiding (occName) +import Var +import Module +import Outputable + +import qualified Data.ByteString as B + +data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan + deriving (Eq,Show) + +-- | Show a GHC syntax tree. This parameterised because it is also used for +-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked +-- out, to avoid comparing locations, only structure +showAstData :: Data a => BlankSrcSpan -> a -> SDoc +showAstData b a0 = blankLine $$ showAstData' a0 + where + showAstData' :: Data a => a -> SDoc + showAstData' = + generic + `ext1Q` list + `extQ` string `extQ` fastString `extQ` srcSpan + `extQ` lit `extQ` litr `extQ` litt + `extQ` bytestring + `extQ` name `extQ` occName `extQ` moduleName `extQ` var + `extQ` dataCon + `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet + `extQ` fixity + `ext2Q` located + + where generic :: Data a => a -> SDoc + generic t = parens $ text (showConstr (toConstr t)) + $$ vcat (gmapQ showAstData' t) + + string :: String -> SDoc + string = text . normalize_newlines . show + + fastString :: FastString -> SDoc + fastString s = braces $ + text "FastString: " + <> text (normalize_newlines . show $ s) + + bytestring :: B.ByteString -> SDoc + bytestring = text . normalize_newlines . show + + list [] = brackets empty + list [x] = brackets (showAstData' x) + list (x1 : x2 : xs) = (text "[" <> showAstData' x1) + $$ go x2 xs + where + go y [] = text "," <> showAstData' y <> text "]" + go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys + + -- Eliminate word-size dependence + lit :: HsLit GhcPs -> SDoc + lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + lit l = generic l + + litr :: HsLit GhcRn -> SDoc + litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litr l = generic l + + litt :: HsLit GhcTc -> SDoc + litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s + litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s + litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s + litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s + litt l = generic l + + numericLit :: String -> Integer -> SourceText -> SDoc + numericLit tag x s = braces $ hsep [ text tag + , generic x + , generic s ] + + name :: Name -> SDoc + name nm = braces $ text "Name: " <> ppr nm + + occName n = braces $ + text "OccName: " + <> text (OccName.occNameString n) + + moduleName :: ModuleName -> SDoc + moduleName m = braces $ text "ModuleName: " <> ppr m + + srcSpan :: SrcSpan -> SDoc + srcSpan ss = case b of + BlankSrcSpan -> text "{ ss }" + NoBlankSrcSpan -> braces $ char ' ' <> + (hang (ppr ss) 1 + -- TODO: show annotations here + (text "")) + + var :: Var -> SDoc + var v = braces $ text "Var: " <> ppr v + + dataCon :: DataCon -> SDoc + dataCon c = braces $ text "DataCon: " <> ppr c + + bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc + bagRdrName bg = braces $ + text "Bag(Located (HsBind GhcPs)):" + $$ (list . bagToList $ bg) + + bagName :: Bag (Located (HsBind GhcRn)) -> SDoc + bagName bg = braces $ + text "Bag(Located (HsBind Name)):" + $$ (list . bagToList $ bg) + + bagVar :: Bag (Located (HsBind GhcTc)) -> SDoc + bagVar bg = braces $ + text "Bag(Located (HsBind Var)):" + $$ (list . bagToList $ bg) + + nameSet ns = braces $ + text "NameSet:" + $$ (list . nameSetElemsStable $ ns) + + fixity :: Fixity -> SDoc + fixity fx = braces $ + text "Fixity: " + <> ppr fx + + located :: (Data b,Data loc) => GenLocated loc b -> SDoc + located (L ss a) = parens $ + case cast ss of + Just (s :: SrcSpan) -> + srcSpan s + Nothing -> text "nnnnnnnn" + $$ showAstData' a + +normalize_newlines :: String -> String +normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs +normalize_newlines (x:xs) = x:normalize_newlines xs +normalize_newlines [] = [] + +{- +************************************************************************ +* * +* Copied from syb +* * +************************************************************************ +-} + + +-- | The type constructor for queries +newtype Q q x = Q { unQ :: x -> q } + +-- | Extend a generic query by a type-specific case +extQ :: ( Typeable a + , Typeable b + ) + => (a -> q) + -> (b -> q) + -> a + -> q +extQ f g a = maybe (f a) g (cast a) + +-- | Type extension of queries for type constructors +ext1Q :: (Data d, Typeable t) + => (d -> q) + -> (forall e. Data e => t e -> q) + -> d -> q +ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) + + +-- | Type extension of queries for type constructors +ext2Q :: (Data d, Typeable t) + => (d -> q) + -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) + -> d -> q +ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) + +-- | Flexible type extension +ext1 :: (Data a, Typeable t) + => c a + -> (forall d. Data d => c (t d)) + -> c a +ext1 def ext = maybe def id (dataCast1 ext) + + + +-- | Flexible type extension +ext2 :: (Data a, Typeable t) + => c a + -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) + -> c a +ext2 def ext = maybe def id (dataCast2 ext) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs new file mode 100644 index 0000000000..2ea1ae3f73 --- /dev/null +++ b/compiler/GHC/Hs/Expr.hs @@ -0,0 +1,2828 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Abstract Haskell syntax for expressions. +module GHC.Hs.Expr where + +#include "HsVersions.h" + +-- friends: +import GhcPrelude + +import GHC.Hs.Decls +import GHC.Hs.Pat +import GHC.Hs.Lit +import GHC.Hs.PlaceHolder ( NameOrRdrName ) +import GHC.Hs.Extension +import GHC.Hs.Types +import GHC.Hs.Binds + +-- others: +import TcEvidence +import CoreSyn +import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) +import Name +import NameSet +import RdrName ( GlobalRdrEnv ) +import BasicTypes +import ConLike +import SrcLoc +import Util +import Outputable +import FastString +import Type +import TcType (TcType) +import {-# SOURCE #-} TcRnTypes (TcLclEnv) + +-- libraries: +import Data.Data hiding (Fixity(..)) +import qualified Data.Data as Data (Fixity(..)) +import Data.Maybe (isNothing) + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified Language.Haskell.TH as TH (Q) + +{- +************************************************************************ +* * +\subsection{Expressions proper} +* * +************************************************************************ +-} + +-- * Expressions proper + +-- | Located Haskell Expression +type LHsExpr p = Located (HsExpr p) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation + +------------------------- +-- | Post-Type checking Expression +-- +-- PostTcExpr is an evidence expression attached to the syntax tree by the +-- type checker (c.f. postTcType). +type PostTcExpr = HsExpr GhcTc + +-- | Post-Type checking Table +-- +-- We use a PostTcTable where there are a bunch of pieces of evidence, more +-- than is convenient to keep individually. +type PostTcTable = [(Name, PostTcExpr)] + +------------------------- +-- | Syntax Expression +-- +-- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, +-- by the renamer. It's used for rebindable syntax. +-- +-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for +-- @(>>=)@, and then instantiated by the type checker with its type args +-- etc +-- +-- This should desugar to +-- +-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) +-- > (syn_arg_wraps[1] arg1) ... +-- +-- where the actual arguments come from elsewhere in the AST. +-- This could be defined using @GhcPass p@ and such, but it's +-- harder to get it all to work out that way. ('noSyntaxExpr' is hard to +-- write, for example.) +data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } + +-- | This is used for rebindable-syntax pieces that are too polymorphic +-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) +noExpr :: HsExpr (GhcPass p) +noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) + +noSyntaxExpr :: SyntaxExpr (GhcPass p) + -- Before renaming, and sometimes after, + -- (if the syntax slot makes no sense) +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField + (HsString NoSourceText + (fsLit "noSyntaxExpr")) + , syn_arg_wraps = [] + , syn_res_wrap = WpHole } + +-- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers. +mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p) +mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr + , syn_arg_wraps = [] + , syn_res_wrap = WpHole } + +-- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the +-- renamer), missing its HsWrappers. +mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn +mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name + -- don't care about filling in syn_arg_wraps because we're clearly + -- not past the typechecker + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (SyntaxExpr p) where + ppr (SyntaxExpr { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = sdocWithDynFlags $ \ dflags -> + getPprStyle $ \s -> + if debugStyle s || gopt Opt_PrintExplicitCoercions dflags + then ppr expr <> braces (pprWithCommas ppr arg_wraps) + <> braces (ppr res_wrap) + else ppr expr + +-- | Command Syntax Table (for Arrow syntax) +type CmdSyntaxTable p = [(Name, HsExpr p)] +-- See Note [CmdSyntaxTable] + +{- +Note [CmdSyntaxtable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is an empty list + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, )] + where is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious RnExpr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) +-} + +-- | An unbound variable; used for treating +-- out-of-scope variables as expression holes +-- +-- Either "x", "y" Plain OutOfScope +-- or "_", "_x" A TrueExprHole +-- +-- Both forms indicate an out-of-scope variable, but the latter +-- indicates that the user /expects/ it to be out of scope, and +-- just wants GHC to report its type +data UnboundVar + = OutOfScope OccName GlobalRdrEnv -- ^ An (unqualified) out-of-scope + -- variable, together with the GlobalRdrEnv + -- with respect to which it is unbound + + -- See Note [OutOfScope and GlobalRdrEnv] + + | TrueExprHole OccName -- ^ A "true" expression hole (_ or _x) + + deriving Data + +instance Outputable UnboundVar where + ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ) + ppr (TrueExprHole occ) = text "ExprHole" <> parens (ppr occ) + +unboundVarOcc :: UnboundVar -> OccName +unboundVarOcc (OutOfScope occ _) = occ +unboundVarOcc (TrueExprHole occ) = occ + +{- +Note [OutOfScope and GlobalRdrEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To understand why we bundle a GlobalRdrEnv with an out-of-scope variable, +consider the following module: + + module A where + + foo :: () + foo = bar + + bat :: [Double] + bat = [1.2, 3.4] + + $(return []) + + bar = () + bad = False + +When A is compiled, the renamer determines that `bar` is not in scope in the +declaration of `foo` (since `bar` is declared in the following inter-splice +group). Once it has finished typechecking the entire module, the typechecker +then generates the associated error message, which specifies both the type of +`bar` and a list of possible in-scope alternatives: + + A.hs:6:7: error: + • Variable not in scope: bar :: () + • ‘bar’ (line 13) is not in scope before the splice on line 11 + Perhaps you meant ‘bat’ (line 9) + +When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the +typechecker must provide a GlobalRdrEnv. If it provided the current one, which +contains top-level declarations for the entire module, the error message would +incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives +for `bar` (see #11680). Instead, the typechecker must use the same +GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope. + +To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope +`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to +look it up in some global store? Unfortunately, no. The problem is that +location information is not always sufficient for this task. This is most +apparent when dealing with the TH function addTopDecls, which adds its +declarations to the FOLLOWING inter-splice group. Consider these declarations: + + ex9 = cat -- cat is NOT in scope here + + $(do ------------------------------------------------------------- + ds <- [d| f = cab -- cat and cap are both in scope here + cat = () + |] + addTopDecls ds + [d| g = cab -- only cap is in scope here + cap = True + |]) + + ex10 = cat -- cat is NOT in scope here + + $(return []) ----------------------------------------------------- + + ex11 = cat -- cat is in scope + +Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs +the GlobalRdrEnvs which were used when they were renamed. These GlobalRdrEnvs +are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the +locations of the two `cab`s are the same (they are both created in the same +splice). Thus, we must include some additional information with each `cab` to +allow the typechecker to obtain the correct GlobalRdrEnv. Clearly, the simplest +information to use is the GlobalRdrEnv itself. +-} + +-- | A Haskell expression. +data HsExpr p + = HsVar (XVar p) + (Located (IdP p)) -- ^ Variable + + -- See Note [Located RdrNames] + + | HsUnboundVar (XUnboundVar p) + UnboundVar -- ^ Unbound variable; also used for "holes" + -- (_ or _x). + -- Turned from HsVar to HsUnboundVar by the + -- renamer, when it finds an out-of-scope + -- variable or hole. + -- Turned into HsVar by type checker, to support + -- deferred type errors. + + | HsConLikeOut (XConLikeOut p) + ConLike -- ^ After typechecker only; must be different + -- HsVar for pretty printing + + | HsRecFld (XRecFld p) + (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector + -- Not in use after typechecking + + | HsOverLabel (XOverLabel p) + (Maybe (IdP p)) FastString + -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) + -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the + -- in-scope 'fromLabel'. + -- NB: Not in use after typechecking + + | HsIPVar (XIPVar p) + HsIPName -- ^ Implicit parameter (not in use after typechecking) + | HsOverLit (XOverLitE p) + (HsOverLit p) -- ^ Overloaded literals + + | HsLit (XLitE p) + (HsLit p) -- ^ Simple (non-overloaded) literals + + | HsLam (XLam p) + (MatchGroup p (LHsExpr p)) + -- ^ Lambda abstraction. Currently always a single match + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application + + | HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application + -- + -- Explicit type argument; e.g f @Int x y + -- NB: Has wildcards, but no implicit quantification + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', + + -- | Operator applications: + -- NB Bracketed ops such as (+) come out as Vars. + + -- NB We need an expr for the operator in an OpApp/Section since + -- the typechecker may need to apply the operator to a few types. + + | OpApp (XOpApp p) + (LHsExpr p) -- left operand + (LHsExpr p) -- operator + (LHsExpr p) -- right operand + + -- | Negation operator. Contains the negated expression and the name + -- of 'negate' + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' + + -- For details on above see note [Api annotations] in ApiAnnotation + | NegApp (XNegApp p) + (LHsExpr p) + (SyntaxExpr p) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsPar (XPar p) + (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + + | SectionL (XSectionL p) + (LHsExpr p) -- operand; see Note [Sections in HsSyn] + (LHsExpr p) -- operator + | SectionR (XSectionR p) + (LHsExpr p) -- operator; see Note [Sections in HsSyn] + (LHsExpr p) -- operand + + -- | Used for explicit tuples and sections thereof + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExplicitTuple + (XExplicitTuple p) + [LHsTupArg p] + Boxity + + -- | Used for unboxed sum types + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, + -- 'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@, + -- + -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before + -- the expression, (arity - alternative) after it + | ExplicitSum + (XExplicitSum p) + ConTag -- Alternative (one-based) + Arity -- Sum arity + (LHsExpr p) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', + -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCase (XCase p) + (LHsExpr p) + (MatchGroup p (LHsExpr p)) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', + -- 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnElse', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsIf (XIf p) + (Maybe (SyntaxExpr p)) -- cond function + -- Nothing => use the built-in 'if' + -- See Note [Rebindable if] + (LHsExpr p) -- predicate + (LHsExpr p) -- then part + (LHsExpr p) -- else part + + -- | Multi-way if + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf' + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] + + -- | let(rec) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', + -- 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsLet (XLet p) + (LHsLocalBinds p) + (LHsExpr p) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', + -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsDo (XDo p) -- Type of the whole expression + (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + (Located [ExprLStmt p]) -- "do":one or more stmts + + -- | Syntactic list: [a,b,c,...] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExplicitList + (XExplicitList p) -- Gives type of components of list + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromListN witness + [LHsExpr p] + + -- | Record construction + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecordCon + { rcon_ext :: XRecordCon p + , rcon_con_name :: Located (IdP p) -- The constructor name; + -- not used after type checking + , rcon_flds :: HsRecordBinds p } -- The fields + + -- | Record update + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecordUpd + { rupd_ext :: XRecordUpd p + , rupd_expr :: LHsExpr p + , rupd_flds :: [LHsRecUpdField p] + } + -- For a type family, the arg types are of the *instance* tycon, + -- not the family tycon + + -- | Expression with an explicit type signature. @e :: type@ + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExprWithTySig + (XExprWithTySig p) + + (LHsExpr p) + (LHsSigWcType (NoGhcTc p)) + + -- | Arithmetic sequence + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | ArithSeq + (XArithSeq p) + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromList witness + (ArithSeqInfo p) + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsSCC (XSCC p) + SourceText -- Note [Pragma source text] in BasicTypes + StringLiteral -- "set cost centre" SCC pragma + (LHsExpr p) -- expr whose cost is to be measured + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, + -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCoreAnn (XCoreAnn p) + SourceText -- Note [Pragma source text] in BasicTypes + StringLiteral -- hdaume: core annotation + (LHsExpr p) + + ----------------------------------------------------------- + -- MetaHaskell Extensions + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ', + -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsBracket (XBracket p) (HsBracket p) + + -- See Note [Pending Splices] + | HsRnBracketOut + (XRnBracketOut p) + (HsBracket GhcRn) -- Output of the renamer is the *original* renamed + -- expression, plus + [PendingRnSplice] -- _renamed_ splices to be type checked + + | HsTcBracketOut + (XTcBracketOut p) + (HsBracket GhcRn) -- Output of the type checker is the *original* + -- renamed expression, plus + [PendingTcSplice] -- _typechecked_ splices to be + -- pasted back in by the desugarer + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsSpliceE (XSpliceE p) (HsSplice p) + + ----------------------------------------------------------- + -- Arrow notation extension + + -- | @proc@ notation for Arrows + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc', + -- 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsProc (XProc p) + (LPat p) -- arrow abstraction, proc + (LHsCmdTop p) -- body of the abstraction + -- always has an empty stack + + --------------------------------------- + -- static pointers extension + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsStatic (XStatic p) -- Free variables of the body + (LHsExpr p) -- Body + + --------------------------------------- + -- Haskell program coverage (Hpc) Support + + | HsTick + (XTick p) + (Tickish (IdP p)) + (LHsExpr p) -- sub-expression + + | HsBinTick + (XBinTick p) + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr p) -- sub-expression + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnMinus', + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsTickPragma -- A pragma introduced tick + (XTickPragma p) + SourceText -- Note [Pragma source text] in BasicTypes + (StringLiteral,(Int,Int),(Int,Int)) + -- external span for this tick + ((SourceText,SourceText),(SourceText,SourceText)) + -- Source text for the four integers used in the span. + -- See note [Pragma source text] in BasicTypes + (LHsExpr p) + + --------------------------------------- + -- Finally, HsWrap appears only in typechecker output + -- The contained Expr is *NOT* itself an HsWrap. + -- See Note [Detecting forced eta expansion] in DsExpr. This invariant + -- is maintained by GHC.Hs.Utils.mkHsWrap. + + | HsWrap (XWrap p) + HsWrapper -- TRANSLATION + (HsExpr p) + + | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor + + +-- | Extra data fields for a 'RecordCon', added by the type checker +data RecordConTc = RecordConTc + { rcon_con_like :: ConLike -- The data constructor or pattern synonym + , rcon_con_expr :: PostTcExpr -- Instantiated constructor function + } + +-- | Extra data fields for a 'RecordUpd', added by the type checker +data RecordUpdTc = RecordUpdTc + { rupd_cons :: [ConLike] + -- Filled in by the type checker to the + -- _non-empty_ list of DataCons that have + -- all the upd'd fields + + , rupd_in_tys :: [Type] -- Argument types of *input* record type + , rupd_out_tys :: [Type] -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] + } deriving Data + +-- --------------------------------------------------------------------- + +type instance XVar (GhcPass _) = NoExtField +type instance XUnboundVar (GhcPass _) = NoExtField +type instance XConLikeOut (GhcPass _) = NoExtField +type instance XRecFld (GhcPass _) = NoExtField +type instance XOverLabel (GhcPass _) = NoExtField +type instance XIPVar (GhcPass _) = NoExtField +type instance XOverLitE (GhcPass _) = NoExtField +type instance XLitE (GhcPass _) = NoExtField +type instance XLam (GhcPass _) = NoExtField +type instance XLamCase (GhcPass _) = NoExtField +type instance XApp (GhcPass _) = NoExtField + +type instance XAppTypeE (GhcPass _) = NoExtField + +type instance XOpApp GhcPs = NoExtField +type instance XOpApp GhcRn = Fixity +type instance XOpApp GhcTc = Fixity + +type instance XNegApp (GhcPass _) = NoExtField +type instance XPar (GhcPass _) = NoExtField +type instance XSectionL (GhcPass _) = NoExtField +type instance XSectionR (GhcPass _) = NoExtField +type instance XExplicitTuple (GhcPass _) = NoExtField + +type instance XExplicitSum GhcPs = NoExtField +type instance XExplicitSum GhcRn = NoExtField +type instance XExplicitSum GhcTc = [Type] + +type instance XCase (GhcPass _) = NoExtField +type instance XIf (GhcPass _) = NoExtField + +type instance XMultiIf GhcPs = NoExtField +type instance XMultiIf GhcRn = NoExtField +type instance XMultiIf GhcTc = Type + +type instance XLet (GhcPass _) = NoExtField + +type instance XDo GhcPs = NoExtField +type instance XDo GhcRn = NoExtField +type instance XDo GhcTc = Type + +type instance XExplicitList GhcPs = NoExtField +type instance XExplicitList GhcRn = NoExtField +type instance XExplicitList GhcTc = Type + +type instance XRecordCon GhcPs = NoExtField +type instance XRecordCon GhcRn = NoExtField +type instance XRecordCon GhcTc = RecordConTc + +type instance XRecordUpd GhcPs = NoExtField +type instance XRecordUpd GhcRn = NoExtField +type instance XRecordUpd GhcTc = RecordUpdTc + +type instance XExprWithTySig (GhcPass _) = NoExtField + +type instance XArithSeq GhcPs = NoExtField +type instance XArithSeq GhcRn = NoExtField +type instance XArithSeq GhcTc = PostTcExpr + +type instance XSCC (GhcPass _) = NoExtField +type instance XCoreAnn (GhcPass _) = NoExtField +type instance XBracket (GhcPass _) = NoExtField + +type instance XRnBracketOut (GhcPass _) = NoExtField +type instance XTcBracketOut (GhcPass _) = NoExtField + +type instance XSpliceE (GhcPass _) = NoExtField +type instance XProc (GhcPass _) = NoExtField + +type instance XStatic GhcPs = NoExtField +type instance XStatic GhcRn = NameSet +type instance XStatic GhcTc = NameSet + +type instance XTick (GhcPass _) = NoExtField +type instance XBinTick (GhcPass _) = NoExtField +type instance XTickPragma (GhcPass _) = NoExtField +type instance XWrap (GhcPass _) = NoExtField +type instance XXExpr (GhcPass _) = NoExtCon + +-- --------------------------------------------------------------------- + +-- | Located Haskell Tuple Argument +-- +-- 'HsTupArg' is used for tuple sections +-- @(,a,)@ is represented by +-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ +-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ +type LHsTupArg id = Located (HsTupArg id) +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Haskell Tuple Argument +data HsTupArg id + = Present (XPresent id) (LHsExpr id) -- ^ The argument + | Missing (XMissing id) -- ^ The argument is missing, but this is its type + | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point + +type instance XPresent (GhcPass _) = NoExtField + +type instance XMissing GhcPs = NoExtField +type instance XMissing GhcRn = NoExtField +type instance XMissing GhcTc = Type + +type instance XXTupArg (GhcPass _) = NoExtCon + +tupArgPresent :: LHsTupArg id -> Bool +tupArgPresent (L _ (Present {})) = True +tupArgPresent (L _ (Missing {})) = False +tupArgPresent (L _ (XTupArg {})) = False + +{- +Note [Parens in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~ +HsPar (and ParPat in patterns, HsParTy in types) is used as follows + + * HsPar is required; the pretty printer does not add parens. + + * HsPars are respected when rearranging operator fixities. + So a * (b + c) means what it says (where the parens are an HsPar) + + * For ParPat and HsParTy the pretty printer does add parens but this should be + a no-op for ParsedSource, based on the pretty printer round trip feature + introduced in + https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c + + * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or + not they are strictly necessary. This should be addressed when #13238 is + completed, to be treated the same as HsPar. + + +Note [Sections in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~ +Sections should always appear wrapped in an HsPar, thus + HsPar (SectionR ...) +The parser parses sections in a wider variety of situations +(See Note [Parsing sections]), but the renamer checks for those +parens. This invariant makes pretty-printing easier; we don't need +a special case for adding the parens round sections. + +Note [Rebindable if] +~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' is a bit special, because when +rebindable syntax is *off* we do not want to treat + (if c then t else e) +as if it was an application (ifThenElse c t e). Why not? +Because we allow an 'if' to return *unboxed* results, thus + if blah then 3# else 4# +whereas that would not be possible using a all to a polymorphic function +(because you can't call a polymorphic function at an unboxed type). + +So we use Nothing to mean "use the old built-in typing rule". + +Note [Record Update HsWrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a wrapper in RecordUpd which is used for the *required* +constraints for pattern synonyms. This wrapper is created in the +typechecking and is then directly used in the desugaring without +modification. + +For example, if we have the record pattern synonym P, + pattern P :: (Show a) => a -> Maybe a + pattern P{x} = Just x + + foo = (Just True) { x = False } +then `foo` desugars to something like + foo = case Just True of + P x -> P False +hence we need to provide the correct dictionaries to P's matcher on +the RHS so that we can build the expression. + +Note [Located RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~ +A number of syntax elements have seemingly redundant locations attached to them. +This is deliberate, to allow transformations making use of the API Annotations +to easily correlate a Located Name in the RenamedSource with a Located RdrName +in the ParsedSource. + +There are unfortunately enough differences between the ParsedSource and the +RenamedSource that the API Annotations cannot be used directly with +RenamedSource, so this allows a simple mapping to be used based on the location. +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) where + ppr expr = pprExpr expr + +----------------------- +-- pprExpr, pprLExpr, pprBinds call pprDeeper; +-- the underscore versions do not +pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc +pprLExpr (L _ e) = pprExpr e + +pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc +pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e + | otherwise = pprDeeper (ppr_expr e) + +isQuietHsExpr :: HsExpr id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsExpr (HsPar {}) = True +-- applications don't display anything themselves +isQuietHsExpr (HsApp {}) = True +isQuietHsExpr (HsAppType {}) = True +isQuietHsExpr (OpApp {}) = True +isQuietHsExpr _ = False + +pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprBinds b = pprDeeper (ppr b) + +----------------------- +ppr_lexpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) + +ppr_expr :: forall p. (OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) -> SDoc +ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v +ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv) +ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c +ppr_expr (HsIPVar _ v) = ppr v +ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l +ppr_expr (HsLit _ lit) = ppr lit +ppr_expr (HsOverLit _ lit) = ppr lit +ppr_expr (HsPar _ e) = parens (ppr_lexpr e) + +ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) + = vcat [pprWithSourceText stc (text "{-# CORE") + <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" + , ppr_lexpr e] + +ppr_expr e@(HsApp {}) = ppr_apps e [] +ppr_expr e@(HsAppType {}) = ppr_apps e [] + +ppr_expr (OpApp _ e1 op e2) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + + where + pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens + pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear + + pp_prefixly + = hang (ppr op) 2 (sep [pp_e1, pp_e2]) + + pp_infixly pp_op + = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) + +ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e + +ppr_expr (SectionL _ expr op) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) + 4 (hsep [pp_expr, text "x_ )"]) + + pp_infixly v = (sep [pp_expr, v]) + +ppr_expr (SectionR _ op expr) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) + 4 (pp_expr <> rparen) + + pp_infixly v = sep [v, pp_expr] + +ppr_expr (ExplicitTuple _ exprs boxity) + = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) + where + ppr_tup_args [] = [] + ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es + ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es + + punc (Present {} : _) = comma <> space + punc (Missing {} : _) = comma + punc (XTupArg {} : _) = comma <> space + punc [] = empty + +ppr_expr (ExplicitSum _ alt arity expr) + = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" + where + ppr_bars n = hsep (replicate n (char '|')) + +ppr_expr (HsLam _ matches) + = pprMatches matches + +ppr_expr (HsLamCase _ matches) + = sep [ sep [text "\\case"], + nest 2 (pprMatches matches) ] + +ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], + nest 2 (pprMatches matches) <+> char '}'] +ppr_expr (HsCase _ expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + nest 2 (pprMatches matches) ] + +ppr_expr (HsIf _ _ e1 e2 e3) + = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], + nest 4 (ppr e2), + text "else", + nest 4 (ppr e3)] + +ppr_expr (HsMultiIf _ alts) + = hang (text "if") 3 (vcat (map ppr_alt alts)) + where ppr_alt (L _ (GRHS _ guards expr)) = + hang vbar 2 (ppr_one one_alt) + where + ppr_one [] = panic "ppr_exp HsMultiIf" + ppr_one (h:t) = hang h 2 (sep t) + one_alt = [ interpp'SP guards + , text "->" <+> pprDeeper (ppr expr) ] + ppr_alt (L _ (XGRHS x)) = ppr x + +-- special case: let ... in let ... +ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lexpr expr] + +ppr_expr (HsLet _ (L _ binds) expr) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr expr)] + +ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts + +ppr_expr (ExplicitList _ _ exprs) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) + = hang (ppr con_id) 2 (ppr rbinds) + +ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) + = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) + +ppr_expr (ExprWithTySig _ expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) + +ppr_expr (ArithSeq _ _ info) = brackets (ppr info) + +ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) + = sep [ pprWithSourceText st (text "{-# SCC") + -- no doublequotes if stl empty, for the case where the SCC was written + -- without quotes. + <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", + ppr expr ] + +ppr_expr (HsWrap _ co_fn e) + = pprHsWrapper co_fn (\parens -> if parens then pprExpr e + else pprExpr e) + +ppr_expr (HsSpliceE _ s) = pprSplice s +ppr_expr (HsBracket _ b) = pprHsBracket b +ppr_expr (HsRnBracketOut _ e []) = ppr e +ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps +ppr_expr (HsTcBracketOut _ e []) = ppr e +ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps + +ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) + = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] +ppr_expr (HsProc _ pat (L _ (XCmdTop x))) + = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x] + +ppr_expr (HsStatic _ e) + = hsep [text "static", ppr e] + +ppr_expr (HsTick _ tickish exp) + = pprTicks (ppr exp) $ + ppr tickish <+> ppr_lexpr exp +ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) + = pprTicks (ppr exp) $ + hcat [text "bintick<", + ppr tickIdTrue, + text ",", + ppr tickIdFalse, + text ">(", + ppr exp, text ")"] +ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) + = pprTicks (ppr exp) $ + hcat [text "tickpragma<", + pprExternalSrcLoc externalSrcLoc, + text ">(", + ppr exp, + text ")"] + +ppr_expr (HsRecFld _ f) = ppr f +ppr_expr (XExpr x) = ppr x + +ppr_infix_expr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> Maybe SDoc +ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) +ppr_infix_expr (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) +ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) +ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) +ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e +ppr_infix_expr _ = Nothing + +ppr_apps :: (OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) + -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] + -> SDoc +ppr_apps (HsApp _ (L _ fun) arg) args + = ppr_apps fun (Left arg : args) +ppr_apps (HsAppType _ (L _ fun) arg) args + = ppr_apps fun (Right arg : args) +ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) + where + pp (Left arg) = ppr arg + -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) + -- = char '@' <> pprHsType arg + pp (Right arg) + = char '@' <> ppr arg + +pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc +pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) + = ppr (src,(n1,n2),(n3,n4)) + +{- +HsSyn records exactly where the user put parens, with HsPar. +So generally speaking we print without adding any parens. +However, some code is internally generated, and in some places +parens are absolutely required; so for these places we use +pprParendLExpr (but don't print double parens of course). + +For operator applications we don't add parens, because the operator +fixities should do the job, except in debug mode (-dppr-debug) so we +can see the structure of the parse tree. +-} + +pprDebugParendExpr :: (OutputableBndrId (GhcPass p)) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprDebugParendExpr p expr + = getPprStyle (\sty -> + if debugStyle sty then pprParendLExpr p expr + else pprLExpr expr) + +pprParendLExpr :: (OutputableBndrId (GhcPass p)) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprParendLExpr p (L _ e) = pprParendExpr p e + +pprParendExpr :: (OutputableBndrId (GhcPass p)) + => PprPrec -> HsExpr (GhcPass p) -> SDoc +pprParendExpr p expr + | hsExprNeedsParens p expr = parens (pprExpr expr) + | otherwise = pprExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right + +-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs +-- parentheses under precedence @p@. +hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool +hsExprNeedsParens p = go + where + go (HsVar{}) = False + go (HsUnboundVar{}) = False + go (HsConLikeOut{}) = False + go (HsIPVar{}) = False + go (HsOverLabel{}) = False + go (HsLit _ l) = hsLitNeedsParens p l + go (HsOverLit _ ol) = hsOverLitNeedsParens p ol + go (HsPar{}) = False + go (HsCoreAnn _ _ _ (L _ e)) = go e + go (HsApp{}) = p >= appPrec + go (HsAppType {}) = p >= appPrec + go (OpApp{}) = p >= opPrec + go (NegApp{}) = p > topPrec + go (SectionL{}) = True + go (SectionR{}) = True + go (ExplicitTuple{}) = False + go (ExplicitSum{}) = False + go (HsLam{}) = p > topPrec + go (HsLamCase{}) = p > topPrec + go (HsCase{}) = p > topPrec + go (HsIf{}) = p > topPrec + go (HsMultiIf{}) = p > topPrec + go (HsLet{}) = p > topPrec + go (HsDo _ sc _) + | isComprehensionContext sc = False + | otherwise = p > topPrec + go (ExplicitList{}) = False + go (RecordUpd{}) = False + go (ExprWithTySig{}) = p >= sigPrec + go (ArithSeq{}) = False + go (HsSCC{}) = p >= appPrec + go (HsWrap _ _ e) = go e + go (HsSpliceE{}) = False + go (HsBracket{}) = False + go (HsRnBracketOut{}) = False + go (HsTcBracketOut{}) = False + go (HsProc{}) = p > topPrec + go (HsStatic{}) = p >= appPrec + go (HsTick _ _ (L _ e)) = go e + go (HsBinTick _ _ _ (L _ e)) = go e + go (HsTickPragma _ _ _ _ (L _ e)) = go e + go (RecordCon{}) = False + go (HsRecFld{}) = False + go (XExpr{}) = True + +-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, +-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. +parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +parenthesizeHsExpr p le@(L loc e) + | hsExprNeedsParens p e = L loc (HsPar noExtField le) + | otherwise = le + +isAtomicHsExpr :: HsExpr id -> Bool +-- True of a single token +isAtomicHsExpr (HsVar {}) = True +isAtomicHsExpr (HsConLikeOut {}) = True +isAtomicHsExpr (HsLit {}) = True +isAtomicHsExpr (HsOverLit {}) = True +isAtomicHsExpr (HsIPVar {}) = True +isAtomicHsExpr (HsOverLabel {}) = True +isAtomicHsExpr (HsUnboundVar {}) = True +isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e +isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) +isAtomicHsExpr (HsRecFld{}) = True +isAtomicHsExpr _ = False + +{- +************************************************************************ +* * +\subsection{Commands (in arrow abstractions)} +* * +************************************************************************ + +We re-use HsExpr to represent these. +-} + +-- | Located Haskell Command (for arrow syntax) +type LHsCmd id = Located (HsCmd id) + +-- | Haskell Command (e.g. a "statement" in an Arrow proc block) +data HsCmd id + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', + -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', + -- 'ApiAnnotation.AnnRarrowtail' + + -- For details on above see note [Api annotations] in ApiAnnotation + = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (XCmdArrApp id) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@, + -- 'ApiAnnotation.AnnCloseB' @'|)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (XCmdArrForm id) + (LHsExpr id) -- The operator. + -- After type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + LexicalFixity -- Whether the operator appeared prefix or infix when + -- parsed. + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands + + | HsCmdApp (XCmdApp id) + (LHsCmd id) + (LHsExpr id) + + | HsCmdLam (XCmdLam id) + (MatchGroup id (LHsCmd id)) -- kappa + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdPar (XCmdPar id) + (LHsCmd id) -- parenthesised command + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdCase (XCmdCase id) + (LHsExpr id) + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', + -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdIf (XCmdIf id) + (Maybe (SyntaxExpr id)) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', + -- 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnElse', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdLet (XCmdLet id) + (LHsLocalBinds id) -- let(rec) + (LHsCmd id) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', + -- 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdDo (XCmdDo id) -- Type of the whole expression + (Located [CmdLStmt id]) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', + -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdWrap (XCmdWrap id) + HsWrapper + (HsCmd id) -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (HsCmdWrap wrap cmd) :: arg2 --> res + | XCmd (XXCmd id) -- Note [Trees that Grow] extension point + +type instance XCmdArrApp GhcPs = NoExtField +type instance XCmdArrApp GhcRn = NoExtField +type instance XCmdArrApp GhcTc = Type + +type instance XCmdArrForm (GhcPass _) = NoExtField +type instance XCmdApp (GhcPass _) = NoExtField +type instance XCmdLam (GhcPass _) = NoExtField +type instance XCmdPar (GhcPass _) = NoExtField +type instance XCmdCase (GhcPass _) = NoExtField +type instance XCmdIf (GhcPass _) = NoExtField +type instance XCmdLet (GhcPass _) = NoExtField + +type instance XCmdDo GhcPs = NoExtField +type instance XCmdDo GhcRn = NoExtField +type instance XCmdDo GhcTc = Type + +type instance XCmdWrap (GhcPass _) = NoExtField +type instance XXCmd (GhcPass _) = NoExtCon + +-- | Haskell Array Application Type +data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp + deriving Data + + +{- | Top-level command, introducing a new arrow. +This may occur inside a proc (where the stack is empty) or as an +argument of a command-forming operator. +-} + +-- | Located Haskell Top-level Command +type LHsCmdTop p = Located (HsCmdTop p) + +-- | Haskell Top-level Command +data HsCmdTop p + = HsCmdTop (XCmdTop p) + (LHsCmd p) + | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point + +data CmdTopTc + = CmdTopTc Type -- Nested tuple of inputs on the command's stack + Type -- return type of the command + (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + +type instance XCmdTop GhcPs = NoExtField +type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] +type instance XCmdTop GhcTc = CmdTopTc + +type instance XXCmdTop (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where + ppr cmd = pprCmd cmd + +----------------------- +-- pprCmd and pprLCmd call pprDeeper; +-- the underscore versions do not +pprLCmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc +pprLCmd (L _ c) = pprCmd c + +pprCmd :: (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc +pprCmd c | isQuietHsCmd c = ppr_cmd c + | otherwise = pprDeeper (ppr_cmd c) + +isQuietHsCmd :: HsCmd id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsCmd (HsCmdPar {}) = True +-- applications don't display anything themselves +isQuietHsCmd (HsCmdApp {}) = True +isQuietHsCmd _ = False + +----------------------- +ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc +ppr_lcmd c = ppr_cmd (unLoc c) + +ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc +ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) + +ppr_cmd (HsCmdApp _ c e) + = let (fun, args) = collect_args c [e] in + hang (ppr_lcmd fun) 2 (sep (map ppr args)) + where + collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +ppr_cmd (HsCmdLam _ matches) + = pprMatches matches + +ppr_cmd (HsCmdCase _ expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + nest 2 (pprMatches matches) ] + +ppr_cmd (HsCmdIf _ _ e ct ce) + = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], + nest 4 (ppr ct), + text "else", + nest 4 (ppr ce)] + +-- special case: let ... in let ... +ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lcmd cmd] + +ppr_cmd (HsCmdLet _ (L _ binds) cmd) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr cmd)] + +ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts + +ppr_cmd (HsCmdWrap _ w cmd) + = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] + +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ op _ _ args) + = hang (text "(|" <+> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") +ppr_cmd (XCmd x) = ppr x + +pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc +pprCmdArg (HsCmdTop _ cmd) + = ppr_lcmd cmd +pprCmdArg (XCmdTop x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where + ppr = pprCmdArg + +{- +************************************************************************ +* * +\subsection{Record binds} +* * +************************************************************************ +-} + +-- | Haskell Record Bindings +type HsRecordBinds p = HsRecFields p (LHsExpr p) + +{- +************************************************************************ +* * +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} +* * +************************************************************************ + +@Match@es are sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, if a function @g@ +is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. + +It is always the case that each element of an @[Match]@ list has the +same number of @pats@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. +-} + +data MatchGroup p body + = MG { mg_ext :: XMG p body -- Posr typechecker, types of args and result + , mg_alts :: Located [LMatch p body] -- The alternatives + , mg_origin :: Origin } + -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns + | XMatchGroup (XXMatchGroup p body) + +data MatchGroupTc + = MatchGroupTc + { mg_arg_tys :: [Type] -- Types of the arguments, t1..tn + , mg_res_ty :: Type -- Type of the result, tr + } deriving Data + +type instance XMG GhcPs b = NoExtField +type instance XMG GhcRn b = NoExtField +type instance XMG GhcTc b = MatchGroupTc + +type instance XXMatchGroup (GhcPass _) b = NoExtCon + +-- | Located Match +type LMatch id body = Located (Match id body) +-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a +-- list + +-- For details on above see note [Api annotations] in ApiAnnotation +data Match p body + = Match { + m_ext :: XCMatch p body, + m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), + -- See note [m_ctxt in Match] + m_pats :: [LPat p], -- The patterns + m_grhss :: (GRHSs p body) + } + | XMatch (XXMatch p body) + +type instance XCMatch (GhcPass _) b = NoExtField +type instance XXMatch (GhcPass _) b = NoExtCon + +instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body) + => Outputable (Match idR body) where + ppr = pprMatch + +{- +Note [m_ctxt in Match] +~~~~~~~~~~~~~~~~~~~~~~ + +A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and +so on. + +In order to simplify tooling processing and pretty print output, the provenance +is captured in an HsMatchContext. + +This is particularly important for the API Annotations for a multi-equation +FunBind. + +The parser initially creates a FunBind with a single Match in it for +every function definition it sees. + +These are then grouped together by getMonoBind into a single FunBind, +where all the Matches are combined. + +In the process, all the original FunBind fun_id's bar one are +discarded, including the locations. + +This causes a problem for source to source conversions via API +Annotations, so the original fun_ids and infix flags are preserved in +the Match, when it originates from a FunBind. + +Example infix function definition requiring individual API Annotations + + (&&& ) [] [] = [] + xs &&& [] = xs + ( &&& ) [] ys = ys + + + +-} + + +isInfixMatch :: Match id body -> Bool +isInfixMatch match = case m_ctxt match of + FunRhs {mc_fixity = Infix} -> True + _ -> False + +isEmptyMatchGroup :: MatchGroup id body -> Bool +isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms +isEmptyMatchGroup (XMatchGroup {}) = False + +-- | Is there only one RHS in this list of matches? +isSingletonMatchGroup :: [LMatch id body] -> Bool +isSingletonMatchGroup matches + | [L _ match] <- matches + , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match + = True + | otherwise + = False + +matchGroupArity :: MatchGroup (GhcPass id) body -> Arity +-- Precondition: MatchGroup is non-empty +-- This is called before type checking, when mg_arg_tys is not set +matchGroupArity (MG { mg_alts = alts }) + | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) + | otherwise = panic "matchGroupArity" +matchGroupArity (XMatchGroup nec) = noExtCon nec + +hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] +hsLMatchPats (L _ (Match { m_pats = pats })) = pats +hsLMatchPats (L _ (XMatch nec)) = noExtCon nec + +-- | Guarded Right-Hand Sides +-- +-- GRHSs are used both for pattern bindings and for Matches +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', +-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' +-- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' + +-- For details on above see note [Api annotations] in ApiAnnotation +data GRHSs p body + = GRHSs { + grhssExt :: XCGRHSs p body, + grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs + grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause + } + | XGRHSs (XXGRHSs p body) + +type instance XCGRHSs (GhcPass _) b = NoExtField +type instance XXGRHSs (GhcPass _) b = NoExtCon + +-- | Located Guarded Right-Hand Side +type LGRHS id body = Located (GRHS id body) + +-- | Guarded Right Hand Side. +data GRHS p body = GRHS (XCGRHS p body) + [GuardLStmt p] -- Guards + body -- Right hand side + | XGRHS (XXGRHS p body) + +type instance XCGRHS (GhcPass _) b = NoExtField +type instance XXGRHS (GhcPass _) b = NoExtCon + +-- We know the list must have at least one @Match@ in it. + +pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc +pprMatches MG { mg_alts = matches } + = vcat (map pprMatch (map unLoc (unLoc matches))) + -- Don't print the type; it's only a place-holder before typechecking +pprMatches (XMatchGroup x) = ppr x + +-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext +pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind matches = pprMatches matches + +-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext +pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr), + OutputableBndrId (GhcPass p), + Outputable body) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc +pprPatBind pat (grhss) + = sep [ppr pat, + nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] + +pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatch match + = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) + , nest 2 (pprGRHSs ctxt (m_grhss match)) ] + where + ctxt = m_ctxt match + (herald, other_pats) + = case ctxt of + FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} + | strictness == SrcStrict -> ASSERT(null $ m_pats match) + (char '!'<>pprPrefixOcc fun, m_pats match) + -- a strict variable binding + | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) + -- f x y z = e + -- Not pprBndr; the AbsBinds will + -- have printed the signature + + | null pats2 -> (pp_infix, []) + -- x &&& y = e + + | otherwise -> (parens pp_infix, pats2) + -- (x &&& y) z = e + where + pp_infix = pprParendLPat opPrec pat1 + <+> pprInfixOcc fun + <+> pprParendLPat opPrec pat2 + + LambdaExpr -> (char '\\', m_pats match) + + _ -> if null (m_pats match) + then (empty, []) + else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 ) + (ppr pat1, []) -- No parens around the single pat + + (pat1:pats1) = m_pats match + (pat2:pats2) = pats1 + +pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body) + => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc +pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) + = vcat (map (pprGRHS ctxt . unLoc) grhss) + -- Print the "where" even if the contents of the binds is empty. Only + -- EmptyLocalBinds means no "where" keyword + $$ ppUnless (eqEmptyLocalBinds binds) + (text "where" $$ nest 4 (pprBinds binds)) +pprGRHSs _ (XGRHSs x) = ppr x + +pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body) + => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc +pprGRHS ctxt (GRHS _ [] body) + = pp_rhs ctxt body + +pprGRHS ctxt (GRHS _ guards body) + = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] + +pprGRHS _ (XGRHS x) = ppr x + +pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) + +{- +************************************************************************ +* * +\subsection{Do stmts and list comprehensions} +* * +************************************************************************ +-} + +-- | Located @do@ block Statement +type LStmt id body = Located (StmtLR id id body) + +-- | Located Statement with separate Left and Right id's +type LStmtLR idL idR body = Located (StmtLR idL idR body) + +-- | @do@ block Statement +type Stmt id body = StmtLR id id body + +-- | Command Located Statement +type CmdLStmt id = LStmt id (LHsCmd id) + +-- | Command Statement +type CmdStmt id = Stmt id (LHsCmd id) + +-- | Expression Located Statement +type ExprLStmt id = LStmt id (LHsExpr id) + +-- | Expression Statement +type ExprStmt id = Stmt id (LHsExpr id) + +-- | Guard Located Statement +type GuardLStmt id = LStmt id (LHsExpr id) + +-- | Guard Statement +type GuardStmt id = Stmt id (LHsExpr id) + +-- | Ghci Located Statement +type GhciLStmt id = LStmt id (LHsExpr id) + +-- | Ghci Statement +type GhciStmt id = Stmt id (LHsExpr id) + +-- The SyntaxExprs in here are used *only* for do-notation and monad +-- comprehensions, which have rebindable syntax. Otherwise they are unused. +-- | API Annotations when in qualifier lists or guards +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen', +-- 'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy', +-- 'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing' + +-- For details on above see note [Api annotations] in ApiAnnotation +data StmtLR idL idR body -- body should always be (LHs**** idR) + = LastStmt -- Always the last Stmt in ListComp, MonadComp, + -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr + -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff + (XLastStmt idL idR body) + body + Bool -- True <=> return was stripped by ApplicativeDo + (SyntaxExpr idR) -- The return operator + -- The return operator is used only for MonadComp + -- For ListComp we use the baked-in 'return' + -- For DoExpr, MDoExpr, we don't apply a 'return' at all + -- See Note [Monad Comprehensions] + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | BindStmt (XBindStmt idL idR body) -- Post typechecking, + -- result type of the function passed to bind; + -- that is, S in (>>=) :: Q -> (R -> S) -> T + (LPat idL) + body + (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts] + (SyntaxExpr idR) -- The fail operator + -- The fail operator is noSyntaxExpr + -- if the pattern match can't fail + + -- | 'ApplicativeStmt' represents an applicative expression built with + -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the + -- appropriate applicative expression by the desugarer, but it is intended + -- to be invisible in error messages. + -- + -- For full details, see Note [ApplicativeDo] in RnExpr + -- + | ApplicativeStmt + (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body + [ ( SyntaxExpr idR + , ApplicativeArg idL) ] + -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] + (Maybe (SyntaxExpr idR)) -- 'join', if necessary + + | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type + -- of the RHS (used for arrows) + body -- See Note [BodyStmt] + (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, + + -- For details on above see note [Api annotations] in ApiAnnotation + | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) + + -- ParStmts only occur in a list/monad comprehension + | ParStmt (XParStmt idL idR body) -- Post typecheck, + -- S in (>>=) :: Q -> (R -> S) -> T + [ParStmtBlock idL idR] + (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions + (SyntaxExpr idR) -- The `>>=` operator + -- See notes [Monad Comprehensions] + -- After renaming, the ids are the binders + -- bound by the stmts and used after themp + + | TransStmt { + trS_ext :: XTransStmt idL idR body, -- Post typecheck, + -- R in (>>=) :: Q -> (R -> S) -> T + trS_form :: TransForm, + trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped + + trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] + + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e + + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms + -- Just a simple HsExpr, because it's + -- too polymorphic for tcSyntaxOp + } -- See Note [Monad Comprehensions] + + -- Recursive statement (see Note [How RecStmt works] below) + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec' + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecStmt + { recS_ext :: XRecStmt idL idR body + , recS_stmts :: [LStmtLR idL idR body] + + -- The next two fields are only valid after renaming + , recS_later_ids :: [IdP idR] + -- The ids are a subset of the variables bound by the + -- stmts that are used in stmts that follow the RecStmt + + , recS_rec_ids :: [IdP idR] + -- Ditto, but these variables are the "recursive" ones, + -- that are used before they are bound in the stmts of + -- the RecStmt. + -- An Id can be in both groups + -- Both sets of Ids are (now) treated monomorphically + -- See Note [How RecStmt works] for why they are separate + + -- Rebindable syntax + , recS_bind_fn :: SyntaxExpr idR -- The bind function + , recS_ret_fn :: SyntaxExpr idR -- The return function + , recS_mfix_fn :: SyntaxExpr idR -- The mfix function + } + | XStmtLR (XXStmtLR idL idR body) + +-- Extra fields available post typechecking for RecStmt. +data RecStmtTc = + RecStmtTc + { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T + , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) + , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. + -- They may not quite be the Ids themselves, + -- because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*, + -- so they may be type applications + + , recS_ret_ty :: Type -- The type of + -- do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). + } + + +type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField + +type instance XBindStmt (GhcPass _) GhcPs b = NoExtField +type instance XBindStmt (GhcPass _) GhcRn b = NoExtField +type instance XBindStmt (GhcPass _) GhcTc b = Type + +type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcTc b = Type + +type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField +type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField +type instance XBodyStmt (GhcPass _) GhcTc b = Type + +type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExtField + +type instance XParStmt (GhcPass _) GhcPs b = NoExtField +type instance XParStmt (GhcPass _) GhcRn b = NoExtField +type instance XParStmt (GhcPass _) GhcTc b = Type + +type instance XTransStmt (GhcPass _) GhcPs b = NoExtField +type instance XTransStmt (GhcPass _) GhcRn b = NoExtField +type instance XTransStmt (GhcPass _) GhcTc b = Type + +type instance XRecStmt (GhcPass _) GhcPs b = NoExtField +type instance XRecStmt (GhcPass _) GhcRn b = NoExtField +type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc + +type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon + +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e (depending on trS_by) + | GroupForm -- then group using f or then group by e using f (depending on trS_by) + deriving Data + +-- | Parenthesised Statement Block +data ParStmtBlock idL idR + = ParStmtBlock + (XParStmtBlock idL idR) + [ExprLStmt idL] + [IdP idR] -- The variables to be returned + (SyntaxExpr idR) -- The return operator + | XParStmtBlock (XXParStmtBlock idL idR) + +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon + +-- | Applicative Argument +data ApplicativeArg idL + = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) + (XApplicativeArgOne idL) + (LPat idL) -- WildPat if it was a BodyStmt (see below) + (LHsExpr idL) + Bool -- True <=> was a BodyStmt + -- False <=> was a BindStmt + -- See Note [Applicative BodyStmt] + + | ApplicativeArgMany -- do { stmts; return vars } + (XApplicativeArgMany idL) + [ExprLStmt idL] -- stmts + (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) + (LPat idL) -- (v1,...,vn) + | XApplicativeArg (XXApplicativeArg idL) + +type instance XApplicativeArgOne (GhcPass _) = NoExtField +type instance XApplicativeArgMany (GhcPass _) = NoExtField +type instance XXApplicativeArg (GhcPass _) = NoExtCon + +{- +Note [The type of bind in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Stmts, notably BindStmt, keep the (>>=) bind operator. +We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b +In some cases (see #303, #1537) it might have a more +exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b +So we must be careful not to make assumptions about the type. +In particular, the monad may not be uniform throughout. + +Note [TransStmt binder map] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The [(idR,idR)] in a TransStmt behaves as follows: + + * Before renaming: [] + + * After renaming: + [ (x27,x27), ..., (z35,z35) ] + These are the variables + bound by the stmts to the left of the 'group' + and used either in the 'by' clause, + or in the stmts following the 'group' + Each item is a pair of identical variables. + + * After typechecking: + [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] + Each pair has the same unique, but different *types*. + +Note [BodyStmt] +~~~~~~~~~~~~~~~ +BodyStmts are a bit tricky, because what they mean +depends on the context. Consider the following contexts: + + A do expression of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E any_ty: do { ....; E; ... } + E :: m any_ty + Translation: E >> ... + + A list comprehensions of type [elt_ty] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + [ .. | ..., E, ... ] + [ .. | .... | ..., E | ... ] + E :: Bool + Translation: if E then fail else ... + + A guard list, guarding a RHS of type rhs_ty + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... + E :: Bool + Translation: if E then fail else ... + + A monad comprehension of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + E :: Bool + Translation: guard E >> ... + +Array comprehensions are handled like list comprehensions. + +Note [How RecStmt works] +~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + HsDo [ BindStmt x ex + + , RecStmt { recS_rec_ids = [a, c] + , recS_stmts = [ BindStmt b (return (a,c)) + , LetStmt a = ...b... + , BindStmt c ec ] + , recS_later_ids = [a, b] + + , return (a b) ] + +Here, the RecStmt binds a,b,c; but + - Only a,b are used in the stmts *following* the RecStmt, + - Only a,c are used in the stmts *inside* the RecStmt + *before* their bindings + +Why do we need *both* rec_ids and later_ids? For monads they could be +combined into a single set of variables, but not for arrows. That +follows from the types of the respective feedback operators: + + mfix :: MonadFix m => (a -> m a) -> m a + loop :: ArrowLoop a => a (b,d) (c,d) -> a b c + +* For mfix, the 'a' covers the union of the later_ids and the rec_ids +* For 'loop', 'c' is the later_ids and 'd' is the rec_ids + +Note [Typing a RecStmt] +~~~~~~~~~~~~~~~~~~~~~~~ +A (RecStmt stmts) types as if you had written + + (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> + do { stmts + ; return (v1,..vn, r1, ..., rm) }) + +where v1..vn are the later_ids + r1..rm are the rec_ids + +Note [Monad Comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Monad comprehensions require separate functions like 'return' and +'>>=' for desugaring. These functions are stored in the statements +used in monad comprehensions. For example, the 'return' of the 'LastStmt' +expression is used to lift the body of the monad comprehension: + + [ body | stmts ] + => + stmts >>= \bndrs -> return body + +In transform and grouping statements ('then ..' and 'then group ..') the +'return' function is required for nested monad comprehensions, for example: + + [ body | stmts, then f, rest ] + => + f [ env | stmts ] >>= \bndrs -> [ body | rest ] + +BodyStmts require the 'Control.Monad.guard' function for boolean +expressions: + + [ body | exp, stmts ] + => + guard exp >> [ body | stmts ] + +Parallel statements require the 'Control.Monad.Zip.mzip' function: + + [ body | stmts1 | stmts2 | .. ] + => + mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body + +In any other context than 'MonadComp', the fields for most of these +'SyntaxExpr's stay bottom. + + +Note [Applicative BodyStmt] + +(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt +as if it was a BindStmt with a wildcard pattern. For example, + + do + x <- A + B + return x + +is transformed as if it were + + do + x <- A + _ <- B + return x + +so it transforms to + + (\(x,_) -> x) <$> A <*> B + +But we have to remember when we treat a BodyStmt like a BindStmt, +because in error messages we want to emit the original syntax the user +wrote, not our internal representation. So ApplicativeArgOne has a +Bool flag that is True when the original statement was a BodyStmt, so +that we can pretty-print it correctly. +-} + +instance (Outputable (StmtLR idL idL (LHsExpr idL)), + Outputable (XXParStmtBlock idL idR)) + => Outputable (ParStmtBlock idL idR) where + ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts + ppr (XParStmtBlock x) = ppr x + +instance (idL ~ GhcPass pl,idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR, + Outputable body) + => Outputable (StmtLR idL idR body) where + ppr stmt = pprStmt stmt + +pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + Outputable body) + => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc +pprStmt (LastStmt _ expr ret_stripped _) + = whenPprDebug (text "[last]") <+> + (if ret_stripped then text "return" else empty) <+> + ppr expr +pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr] +pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] +pprStmt (BodyStmt _ expr _ _) = ppr expr +pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) + +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by + , trS_using = using, trS_form = form }) + = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) + +pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids + , recS_later_ids = later_ids }) + = text "rec" <+> + vcat [ ppr_do_stmts segment + , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids + , text "later_ids=" <> ppr later_ids])] + +pprStmt (ApplicativeStmt _ args mb_join) + = getPprStyle $ \style -> + if userStyle style + then pp_for_user + else pp_debug + where + -- make all the Applicative stuff invisible in error messages by + -- flattening the whole ApplicativeStmt nest back to a sequence + -- of statements. + pp_for_user = vcat $ concatMap flattenArg args + + -- ppr directly rather than transforming here, because we need to + -- inject a "return" which is hard when we're polymorphic in the id + -- type. + flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] + flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args + flattenStmt stmt = [ppr stmt] + + flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] + flattenArg (_, ApplicativeArgOne _ pat expr isBody) + | isBody = -- See Note [Applicative BodyStmt] + [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL))] + | otherwise = + [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL))] + flattenArg (_, ApplicativeArgMany _ stmts _ _) = + concatMap flattenStmt stmts + flattenArg (_, XApplicativeArg nec) = noExtCon nec + + pp_debug = + let + ap_expr = sep (punctuate (text " |") (map pp_arg args)) + in + if isNothing mb_join + then ap_expr + else text "join" <+> parens ap_expr + + pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc + pp_arg (_, ApplicativeArgOne _ pat expr isBody) + | isBody = -- See Note [Applicative BodyStmt] + ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL)) + | otherwise = + ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL)) + pp_arg (_, ApplicativeArgMany _ stmts return pat) = + ppr pat <+> + text "<-" <+> + ppr (HsDo (panic "pprStmt") DoExpr (noLoc + (stmts ++ + [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)]))) + pp_arg (_, XApplicativeArg x) = ppr x + +pprStmt (XStmtLR x) = ppr x + +pprTransformStmt :: (OutputableBndrId (GhcPass p)) + => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) + -> Maybe (LHsExpr (GhcPass p)) -> SDoc +pprTransformStmt bndrs using by + = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) + , nest 2 (ppr using) + , nest 2 (pprBy by)] + +pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc +pprTransStmt by using ThenForm + = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by using GroupForm + = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] + +pprBy :: Outputable body => Maybe body -> SDoc +pprBy Nothing = empty +pprBy (Just e) = text "by" <+> ppr e + +pprDo :: (OutputableBndrId (GhcPass p), Outputable body) + => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc +pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts +pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts +pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +ppr_do_stmts :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), + Outputable body) + => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc +-- Print a bunch of do stmts +ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) + +pprComp :: (OutputableBndrId (GhcPass p), Outputable body) + => [LStmt (GhcPass p) body] -> SDoc +pprComp quals -- Prints: body | qual1, ..., qualn + | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals + = if null initStmts + -- If there are no statements in a list comprehension besides the last + -- one, we simply treat it like a normal list. This does arise + -- occasionally in code that GHC generates, e.g., in implementations of + -- 'range' for derived 'Ix' instances for product datatypes with exactly + -- one constructor (e.g., see #12583). + then ppr body + else hang (ppr body <+> vbar) 2 (pprQuals initStmts) + | otherwise + = pprPanic "pprComp" (pprQuals quals) + +pprQuals :: (OutputableBndrId (GhcPass p), Outputable body) + => [LStmt (GhcPass p) body] -> SDoc +-- Show list comprehension qualifiers separated by commas +pprQuals quals = interpp'SP quals + +{- +************************************************************************ +* * + Template Haskell quotation brackets +* * +************************************************************************ +-} + +-- | Haskell Splice +data HsSplice id + = HsTypedSplice -- $$z or $$(f 4) + (XTypedSplice id) + SpliceDecoration -- Whether $$( ) variant found, for pretty printing + (IdP id) -- A unique name to identify this splice point + (LHsExpr id) -- See Note [Pending Splices] + + | HsUntypedSplice -- $z or $(f 4) + (XUntypedSplice id) + SpliceDecoration -- Whether $( ) variant found, for pretty printing + (IdP id) -- A unique name to identify this splice point + (LHsExpr id) -- See Note [Pending Splices] + + | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice + (XQuasiQuote id) + (IdP id) -- Splice point + (IdP id) -- Quoter + SrcSpan -- The span of the enclosed string + FastString -- The enclosed string + + -- AZ:TODO: use XSplice instead of HsSpliced + | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in + -- RnSplice. + -- This is the result of splicing a splice. It is produced by + -- the renamer and consumed by the typechecker. It lives only + -- between the two. + (XSpliced id) + ThModFinalizers -- TH finalizers produced by the splice. + (HsSplicedThing id) -- The result of splicing + | HsSplicedT + DelayedSplice + | XSplice (XXSplice id) -- Note [Trees that Grow] extension point + +type instance XTypedSplice (GhcPass _) = NoExtField +type instance XUntypedSplice (GhcPass _) = NoExtField +type instance XQuasiQuote (GhcPass _) = NoExtField +type instance XSpliced (GhcPass _) = NoExtField +type instance XXSplice (GhcPass _) = NoExtCon + +-- | A splice can appear with various decorations wrapped around it. This data +-- type captures explicitly how it was originally written, for use in the pretty +-- printer. +data SpliceDecoration + = HasParens -- ^ $( splice ) or $$( splice ) + | HasDollar -- ^ $splice or $$splice + | NoParens -- ^ bare splice + deriving (Data, Eq, Show) + +instance Outputable SpliceDecoration where + ppr x = text $ show x + + +isTypedSplice :: HsSplice id -> Bool +isTypedSplice (HsTypedSplice {}) = True +isTypedSplice _ = False -- Quasi-quotes are untyped splices + +-- | Finalizers produced by a splice with +-- 'Language.Haskell.TH.Syntax.addModFinalizer' +-- +-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how +-- this is used. +-- +newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] + +-- A Data instance which ignores the argument of 'ThModFinalizers'. +instance Data ThModFinalizers where + gunfold _ z _ = z $ ThModFinalizers [] + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] + +-- See Note [Running typed splices in the zonker] +-- These are the arguments that are passed to `TcSplice.runTopSplice` +data DelayedSplice = + DelayedSplice + TcLclEnv -- The local environment to run the splice in + (LHsExpr GhcRn) -- The original renamed expression + TcType -- The result type of running the splice, unzonked + (LHsExpr GhcTcId) -- The typechecked expression to run and splice in the result + +-- A Data instance which ignores the argument of 'DelayedSplice'. +instance Data DelayedSplice where + gunfold _ _ _ = panic "DelayedSplice" + toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] + +-- | Haskell Spliced Thing +-- +-- Values that can result from running a splice. +data HsSplicedThing id + = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression + | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type + | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern + + +-- See Note [Pending Splices] +type SplicePointName = Name + +-- | Pending Renamer Splice +data PendingRnSplice + = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) + +data UntypedSpliceFlavour + = UntypedExpSplice + | UntypedPatSplice + | UntypedTypeSplice + | UntypedDeclSplice + deriving Data + +-- | Pending Type-checker Splice +data PendingTcSplice + = PendingTcSplice SplicePointName (LHsExpr GhcTc) + +{- +Note [Pending Splices] +~~~~~~~~~~~~~~~~~~~~~~ +When we rename an untyped bracket, we name and lift out all the nested +splices, so that when the typechecker hits the bracket, it can +typecheck those nested splices without having to walk over the untyped +bracket code. So for example + [| f $(g x) |] +looks like + + HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) + +which the renamer rewrites to + + HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) + [PendingRnSplice UntypedExpSplice sn (g x)] + +* The 'sn' is the Name of the splice point, the SplicePointName + +* The PendingRnExpSplice gives the splice that splice-point name maps to; + and the typechecker can now conveniently find these sub-expressions + +* The other copy of the splice, in the second argument of HsSpliceE + in the renamed first arg of HsRnBracketOut + is used only for pretty printing + +There are four varieties of pending splices generated by the renamer, +distinguished by their UntypedSpliceFlavour + + * Pending expression splices (UntypedExpSplice), e.g., + [|$(f x) + 2|] + + UntypedExpSplice is also used for + * quasi-quotes, where the pending expression expands to + $(quoter "...blah...") + (see RnSplice.makePending, HsQuasiQuote case) + + * cross-stage lifting, where the pending expression expands to + $(lift x) + (see RnSplice.checkCrossStageLifting) + + * Pending pattern splices (UntypedPatSplice), e.g., + [| \$(f x) -> x |] + + * Pending type splices (UntypedTypeSplice), e.g., + [| f :: $(g x) |] + + * Pending declaration (UntypedDeclSplice), e.g., + [| let $(f x) in ... |] + +There is a fifth variety of pending splice, which is generated by the type +checker: + + * Pending *typed* expression splices, (PendingTcSplice), e.g., + [||1 + $$(f 2)||] + +It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the +output of the renamer. However, when pretty printing the output of the renamer, +e.g., in a type error message, we *do not* want to print out the pending +splices. In contrast, when pretty printing the output of the type checker, we +*do* want to print the pending splices. So splitting them up seems to make +sense, although I hate to add another constructor to HsExpr. +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsSplicedThing p) where + ppr (HsSplicedExpr e) = ppr_expr e + ppr (HsSplicedTy t) = ppr t + ppr (HsSplicedPat p) = ppr p + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsSplice p) where + ppr s = pprSplice s + +pprPendingSplice :: (OutputableBndrId (GhcPass p)) + => SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) + +pprSpliceDecl :: (OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e +pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" +pprSpliceDecl e ImplicitSplice = ppr_splice_decl e + +ppr_splice_decl :: (OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SDoc +ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty +ppr_splice_decl e = pprSplice e + +pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc +pprSplice (HsTypedSplice _ HasParens n e) + = ppr_splice (text "$$(") n e (text ")") +pprSplice (HsTypedSplice _ HasDollar n e) + = ppr_splice (text "$$") n e empty +pprSplice (HsTypedSplice _ NoParens n e) + = ppr_splice empty n e empty +pprSplice (HsUntypedSplice _ HasParens n e) + = ppr_splice (text "$(") n e (text ")") +pprSplice (HsUntypedSplice _ HasDollar n e) + = ppr_splice (text "$") n e empty +pprSplice (HsUntypedSplice _ NoParens n e) + = ppr_splice empty n e empty +pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s +pprSplice (HsSpliced _ _ thing) = ppr thing +pprSplice (HsSplicedT {}) = text "Unevaluated typed splice" +pprSplice (XSplice x) = ppr x + +ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc +ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> + char '[' <> ppr quoter <> vbar <> + ppr quote <> text "|]" + +ppr_splice :: (OutputableBndrId (GhcPass p)) + => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc +ppr_splice herald n e trail + = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail + +-- | Haskell Bracket +data HsBracket p + = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] + | PatBr (XPatBr p) (LPat p) -- [p| pat |] + | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser + | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer + | TypBr (XTypBr p) (LHsType p) -- [t| type |] + | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T + -- (The Bool flag is used only in pprHsBracket) + | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] + | XBracket (XXBracket p) -- Note [Trees that Grow] extension point + +type instance XExpBr (GhcPass _) = NoExtField +type instance XPatBr (GhcPass _) = NoExtField +type instance XDecBrL (GhcPass _) = NoExtField +type instance XDecBrG (GhcPass _) = NoExtField +type instance XTypBr (GhcPass _) = NoExtField +type instance XVarBr (GhcPass _) = NoExtField +type instance XTExpBr (GhcPass _) = NoExtField +type instance XXBracket (GhcPass _) = NoExtCon + +isTypedBracket :: HsBracket id -> Bool +isTypedBracket (TExpBr {}) = True +isTypedBracket _ = False + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsBracket p) where + ppr = pprHsBracket + + +pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc +pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) +pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) +pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) +pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr _ True n) + = char '\'' <> pprPrefixOcc n +pprHsBracket (VarBr _ False n) + = text "''" <> pprPrefixOcc n +pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) +pprHsBracket (XBracket e) = ppr e + +thBrackets :: SDoc -> SDoc -> SDoc +thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> + pp_body <+> text "|]" + +thTyBrackets :: SDoc -> SDoc +thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") + +instance Outputable PendingRnSplice where + ppr (PendingRnSplice _ n e) = pprPendingSplice n e + +instance Outputable PendingTcSplice where + ppr (PendingTcSplice n e) = pprPendingSplice n e + +{- +************************************************************************ +* * +\subsection{Enumerations and list comprehensions} +* * +************************************************************************ +-} + +-- | Arithmetic Sequence Information +data ArithSeqInfo id + = From (LHsExpr id) + | FromThen (LHsExpr id) + (LHsExpr id) + | FromTo (LHsExpr id) + (LHsExpr id) + | FromThenTo (LHsExpr id) + (LHsExpr id) + (LHsExpr id) +-- AZ: Sould ArithSeqInfo have a TTG extension? + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ArithSeqInfo p) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] + +pp_dotdot :: SDoc +pp_dotdot = text " .. " + +{- +************************************************************************ +* * +\subsection{HsMatchCtxt} +* * +************************************************************************ +-} + +-- | Haskell Match Context +-- +-- Context of a pattern match. This is more subtle than it would seem. See Note +-- [Varieties of pattern matches]. +data HsMatchContext id -- Not an extensible tag + = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ + , mc_fixity :: LexicalFixity -- ^ fixing of @f@ + , mc_strictness :: SrcStrictness -- ^ was @f@ banged? + -- See Note [FunBind vs PatBind] + } + -- ^A pattern matching on an argument of a + -- function binding + | LambdaExpr -- ^Patterns of a lambda + | CaseAlt -- ^Patterns and guards on a case alternative + | IfAlt -- ^Guards of a multi-way if alternative + | ProcExpr -- ^Patterns of a proc + | PatBindRhs -- ^A pattern binding eg [y] <- e = e + | PatBindGuards -- ^Guards of pattern bindings, e.g., + -- (Just b) | Just _ <- x = e + -- | otherwise = e' + + | RecUpd -- ^Record update [used only in DsExpr to + -- tell matchWrapper what sort of + -- runtime error message to generate] + + | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, + -- pattern guard, etc + + | ThPatSplice -- ^A Template Haskell pattern splice + | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] + | PatSyn -- ^A pattern synonym declaration + deriving Functor +deriving instance (Data id) => Data (HsMatchContext id) + +instance OutputableBndr id => Outputable (HsMatchContext id) where + ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) + ppr LambdaExpr = text "LambdaExpr" + ppr CaseAlt = text "CaseAlt" + ppr IfAlt = text "IfAlt" + ppr ProcExpr = text "ProcExpr" + ppr PatBindRhs = text "PatBindRhs" + ppr PatBindGuards = text "PatBindGuards" + ppr RecUpd = text "RecUpd" + ppr (StmtCtxt _) = text "StmtCtxt _" + ppr ThPatSplice = text "ThPatSplice" + ppr ThPatQuote = text "ThPatQuote" + ppr PatSyn = text "PatSyn" + +isPatSynCtxt :: HsMatchContext id -> Bool +isPatSynCtxt ctxt = + case ctxt of + PatSyn -> True + _ -> False + +-- | Haskell Statement Context. It expects to be parameterised with one of +-- 'RdrName', 'Name' or 'Id' +data HsStmtContext id + = ListComp + | MonadComp + + | DoExpr -- ^do { ... } + | MDoExpr -- ^mdo { ... } ie recursive do-expression + | ArrowExpr -- ^do-notation in an arrow-command context + + | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs + | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt + deriving Functor +deriving instance (Data id) => Data (HsStmtContext id) + +isComprehensionContext :: HsStmtContext id -> Bool +-- Uses comprehension syntax [ e | quals ] +isComprehensionContext ListComp = True +isComprehensionContext MonadComp = True +isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c +isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c +isComprehensionContext _ = False + +-- | Should pattern match failure in a 'HsStmtContext' be desugared using +-- 'MonadFail'? +isMonadFailStmtContext :: HsStmtContext id -> Bool +isMonadFailStmtContext MonadComp = True +isMonadFailStmtContext DoExpr = True +isMonadFailStmtContext MDoExpr = True +isMonadFailStmtContext GhciStmtCtxt = True +isMonadFailStmtContext (ParStmtCtxt ctxt) = isMonadFailStmtContext ctxt +isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt +isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr + +isMonadCompContext :: HsStmtContext id -> Bool +isMonadCompContext MonadComp = True +isMonadCompContext _ = False + +matchSeparator :: HsMatchContext id -> SDoc +matchSeparator (FunRhs {}) = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator IfAlt = text "->" +matchSeparator LambdaExpr = text "->" +matchSeparator ProcExpr = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator (StmtCtxt _) = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern + -- match checker trace +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" +matchSeparator PatSyn = panic "unused" + +pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) + => HsMatchContext id -> SDoc +pprMatchContext ctxt + | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt + | otherwise = text "a" <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an ProcExpr = True + want_an _ = False + +pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) + => HsMatchContext id -> SDoc +pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) + = text "equation for" + <+> quotes (ppr fun) +pprMatchContextNoun CaseAlt = text "case alternative" +pprMatchContextNoun IfAlt = text "multi-way if alternative" +pprMatchContextNoun RecUpd = text "record-update construct" +pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" +pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" +pprMatchContextNoun PatBindRhs = text "pattern binding" +pprMatchContextNoun PatBindGuards = text "pattern binding guards" +pprMatchContextNoun LambdaExpr = text "lambda abstraction" +pprMatchContextNoun ProcExpr = text "arrow abstraction" +pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" + $$ pprAStmtContext ctxt +pprMatchContextNoun PatSyn = text "pattern synonym declaration" + +----------------- +pprAStmtContext, pprStmtContext :: (Outputable id, + Outputable (NameOrRdrName id)) + => HsStmtContext id -> SDoc +pprAStmtContext ctxt = article <+> pprStmtContext ctxt + where + pp_an = text "an" + pp_a = text "a" + article = case ctxt of + MDoExpr -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a + + +----------------- +pprStmtContext GhciStmtCtxt = text "interactive GHCi command" +pprStmtContext DoExpr = text "'do' block" +pprStmtContext MDoExpr = text "'mdo' block" +pprStmtContext ArrowExpr = text "'do' block in an arrow command" +pprStmtContext ListComp = text "list comprehension" +pprStmtContext MonadComp = text "monad comprehension" +pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension +pprStmtContext (ParStmtCtxt c) = + ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) + (pprStmtContext c) +pprStmtContext (TransStmtCtxt c) = + ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) + (pprStmtContext c) + +instance (Outputable p, Outputable (NameOrRdrName p)) + => Outputable (HsStmtContext p) where + ppr = pprStmtContext + +-- Used to generate the string for a *runtime* error message +matchContextErrString :: Outputable id + => HsMatchContext id -> SDoc +matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun +matchContextErrString CaseAlt = text "case" +matchContextErrString IfAlt = text "multi-way if" +matchContextErrString PatBindRhs = text "pattern binding" +matchContextErrString PatBindGuards = text "pattern binding guards" +matchContextErrString RecUpd = text "record update" +matchContextErrString LambdaExpr = text "lambda" +matchContextErrString ProcExpr = text "proc" +matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime +matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime +matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" +matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command" +matchContextErrString (StmtCtxt DoExpr) = text "'do' block" +matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block" +matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" +matchContextErrString (StmtCtxt ListComp) = text "list comprehension" +matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" + +pprMatchInCtxt :: (OutputableBndrId (GhcPass idR), + -- TODO:AZ these constraints do not make sense + Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), + Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) + <> colon) + 4 (pprMatch match) + +pprStmtInCtxt :: (OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + Outputable body) + => HsStmtContext (IdP (GhcPass idL)) + -> StmtLR (GhcPass idL) (GhcPass idR) body + -> SDoc +pprStmtInCtxt ctxt (LastStmt _ e _ _) + | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts" + = hang (text "In the expression:") 2 (ppr e) + +pprStmtInCtxt ctxt stmt + = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) + where + -- For Group and Transform Stmts, don't print the nested stmts! + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot new file mode 100644 index 0000000000..8fd8f3857a --- /dev/null +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP, KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Hs.Expr where + +import SrcLoc ( Located ) +import Outputable ( SDoc, Outputable ) +import {-# SOURCE #-} GHC.Hs.Pat ( LPat ) +import BasicTypes ( SpliceExplicitFlag(..)) +import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) + +type role HsExpr nominal +type role HsCmd nominal +type role MatchGroup nominal nominal +type role GRHSs nominal nominal +type role HsSplice nominal +type role SyntaxExpr nominal +data HsExpr (i :: *) +data HsCmd (i :: *) +data HsSplice (i :: *) +data MatchGroup (a :: *) (body :: *) +data GRHSs (a :: *) (body :: *) +data SyntaxExpr (i :: *) + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) + +type LHsExpr a = Located (HsExpr a) + +pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc + +pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc + +pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc + +pprSpliceDecl :: (OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc + +pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr), + OutputableBndrId (GhcPass p), + Outputable body) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc + +pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs new file mode 100644 index 0000000000..f360e1c32e --- /dev/null +++ b/compiler/GHC/Hs/Extension.hs @@ -0,0 +1,1168 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder + +module GHC.Hs.Extension where + +-- This module captures the type families to precisely identify the extension +-- points for GHC.Hs syntax + +import GhcPrelude + +import Data.Data hiding ( Fixity ) +import GHC.Hs.PlaceHolder +import Name +import RdrName +import Var +import Outputable +import SrcLoc (Located) + +import Data.Kind + +{- +Note [Trees that grow] +~~~~~~~~~~~~~~~~~~~~~~ + +See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow + +The hsSyn AST is reused across multiple compiler passes. We also have the +Template Haskell AST, and the haskell-src-exts one (outside of GHC) + +Supporting multiple passes means the AST has various warts on it to cope with +the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut', +'SigPatOut' etc. + +The growable AST will allow each of these variants to be captured explicitly, +such that they only exist in the given compiler pass AST, as selected by the +type parameter to the AST. + +In addition it will allow tool writers to define their own extensions to capture +additional information for the tool, in a natural way. + +A further goal is to provide a means to harmonise the Template Haskell and +haskell-src-exts ASTs as well. + +-} + +-- | A placeholder type for TTG extension points that are not currently +-- unused to represent any particular value. +-- +-- This should not be confused with 'NoExtCon', which are found in unused +-- extension /constructors/ and therefore should never be inhabited. In +-- contrast, 'NoExtField' is used in extension /points/ (e.g., as the field of +-- some constructor), so it must have an inhabitant to construct AST passes +-- that manipulate fields with that extension point as their type. +data NoExtField = NoExtField + deriving (Data,Eq,Ord) + +instance Outputable NoExtField where + ppr _ = text "NoExtField" + +-- | Used when constructing a term with an unused extension point. +noExtField :: NoExtField +noExtField = NoExtField + +-- | Used in TTG extension constructors that have yet to be extended with +-- anything. If an extension constructor has 'NoExtCon' as its field, it is +-- not intended to ever be constructed anywhere, and any function that consumes +-- the extension constructor can eliminate it by way of 'noExtCon'. +-- +-- This should not be confused with 'NoExtField', which are found in unused +-- extension /points/ (not /constructors/) and therefore can be inhabited. + +-- See also [NoExtCon and strict fields]. +data NoExtCon + deriving (Data,Eq,Ord) + +instance Outputable NoExtCon where + ppr = noExtCon + +-- | Eliminate a 'NoExtCon'. Much like 'Data.Void.absurd'. +noExtCon :: NoExtCon -> a +noExtCon x = case x of {} + +{- +Note [NoExtCon and strict fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, any unused TTG extension constructor will generally look like the +following: + + type instance XXHsDecl (GhcPass _) = NoExtCon + data HsDecl p + = ... + | XHsDecl (XXHsDecl p) + +This means that any function that wishes to consume an HsDecl will need to +have a case for XHsDecl. This might look like this: + + ex :: HsDecl GhcPs -> HsDecl GhcRn + ... + ex (XHsDecl nec) = noExtCon nec + +Ideally, we wouldn't need a case for XHsDecl at all (it /is/ supposed to be +an unused extension constructor, after all). There is a way to achieve this +on GHC 8.8 or later: make the field of XHsDecl strict: + + data HsDecl p + = ... + | XHsDecl !(XXHsDecl p) + +If this is done, GHC's pattern-match coverage checker is clever enough to +figure out that the XHsDecl case of `ex` is unreachable, so it can simply be +omitted. (See Note [Extensions to GADTs Meet Their Match] in Check for more on +how this works.) + +When GHC drops support for bootstrapping with GHC 8.6 and earlier, we can make +the strict field changes described above and delete gobs of code involving +`noExtCon`. Until then, it is necessary to use, so be aware of it when writing +code that consumes unused extension constructors. +-} + +-- | Used as a data type index for the hsSyn AST +data GhcPass (c :: Pass) +deriving instance Eq (GhcPass c) +deriving instance Typeable c => Data (GhcPass c) + +data Pass = Parsed | Renamed | Typechecked + deriving (Data) + +-- Type synonyms as a shorthand for tagging +type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param +type GhcRn = GhcPass 'Renamed -- Old 'Name' type param +type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, +type GhcTcId = GhcTc -- Old 'TcId' type param + +-- | Maps the "normal" id type for a given pass +type family IdP p +type instance IdP GhcPs = RdrName +type instance IdP GhcRn = Name +type instance IdP GhcTc = Id + +type LIdP p = Located (IdP p) + +-- | Marks that a field uses the GhcRn variant even when the pass +-- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because +-- HsType GhcTc should never occur. +type family NoGhcTc (p :: Type) where + -- this way, GHC can figure out that the result is a GhcPass + NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) + NoGhcTc other = other + +type family NoGhcTcPass (p :: Pass) :: Pass where + NoGhcTcPass 'Typechecked = 'Renamed + NoGhcTcPass other = other + +-- ===================================================================== +-- Type families for the HsBinds extension points + +-- HsLocalBindsLR type families +type family XHsValBinds x x' +type family XHsIPBinds x x' +type family XEmptyLocalBinds x x' +type family XXHsLocalBindsLR x x' + +type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XHsValBinds x x') + , c (XHsIPBinds x x') + , c (XEmptyLocalBinds x x') + , c (XXHsLocalBindsLR x x') + ) + +-- ValBindsLR type families +type family XValBinds x x' +type family XXValBindsLR x x' + +type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XValBinds x x') + , c (XXValBindsLR x x') + ) + + +-- HsBindsLR type families +type family XFunBind x x' +type family XPatBind x x' +type family XVarBind x x' +type family XAbsBinds x x' +type family XPatSynBind x x' +type family XXHsBindsLR x x' + +type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XFunBind x x') + , c (XPatBind x x') + , c (XVarBind x x') + , c (XAbsBinds x x') + , c (XPatSynBind x x') + , c (XXHsBindsLR x x') + ) + +-- ABExport type families +type family XABE x +type family XXABExport x + +type ForallXABExport (c :: * -> Constraint) (x :: *) = + ( c (XABE x) + , c (XXABExport x) + ) + +-- PatSynBind type families +type family XPSB x x' +type family XXPatSynBind x x' + +type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XPSB x x') + , c (XXPatSynBind x x') + ) + +-- HsIPBinds type families +type family XIPBinds x +type family XXHsIPBinds x + +type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) = + ( c (XIPBinds x) + , c (XXHsIPBinds x) + ) + +-- IPBind type families +type family XCIPBind x +type family XXIPBind x + +type ForallXIPBind (c :: * -> Constraint) (x :: *) = + ( c (XCIPBind x) + , c (XXIPBind x) + ) + +-- Sig type families +type family XTypeSig x +type family XPatSynSig x +type family XClassOpSig x +type family XIdSig x +type family XFixSig x +type family XInlineSig x +type family XSpecSig x +type family XSpecInstSig x +type family XMinimalSig x +type family XSCCFunSig x +type family XCompleteMatchSig x +type family XXSig x + +type ForallXSig (c :: * -> Constraint) (x :: *) = + ( c (XTypeSig x) + , c (XPatSynSig x) + , c (XClassOpSig x) + , c (XIdSig x) + , c (XFixSig x) + , c (XInlineSig x) + , c (XSpecSig x) + , c (XSpecInstSig x) + , c (XMinimalSig x) + , c (XSCCFunSig x) + , c (XCompleteMatchSig x) + , c (XXSig x) + ) + +-- FixitySig type families +type family XFixitySig x +type family XXFixitySig x + +type ForallXFixitySig (c :: * -> Constraint) (x :: *) = + ( c (XFixitySig x) + , c (XXFixitySig x) + ) + +-- ===================================================================== +-- Type families for the HsDecls extension points + +-- HsDecl type families +type family XTyClD x +type family XInstD x +type family XDerivD x +type family XValD x +type family XSigD x +type family XDefD x +type family XForD x +type family XWarningD x +type family XAnnD x +type family XRuleD x +type family XSpliceD x +type family XDocD x +type family XRoleAnnotD x +type family XXHsDecl x + +type ForallXHsDecl (c :: * -> Constraint) (x :: *) = + ( c (XTyClD x) + , c (XInstD x) + , c (XDerivD x) + , c (XValD x) + , c (XSigD x) + , c (XDefD x) + , c (XForD x) + , c (XWarningD x) + , c (XAnnD x) + , c (XRuleD x) + , c (XSpliceD x) + , c (XDocD x) + , c (XRoleAnnotD x) + , c (XXHsDecl x) + ) + +-- ------------------------------------- +-- HsGroup type families +type family XCHsGroup x +type family XXHsGroup x + +type ForallXHsGroup (c :: * -> Constraint) (x :: *) = + ( c (XCHsGroup x) + , c (XXHsGroup x) + ) + +-- ------------------------------------- +-- SpliceDecl type families +type family XSpliceDecl x +type family XXSpliceDecl x + +type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) = + ( c (XSpliceDecl x) + , c (XXSpliceDecl x) + ) + +-- ------------------------------------- +-- TyClDecl type families +type family XFamDecl x +type family XSynDecl x +type family XDataDecl x +type family XClassDecl x +type family XXTyClDecl x + +type ForallXTyClDecl (c :: * -> Constraint) (x :: *) = + ( c (XFamDecl x) + , c (XSynDecl x) + , c (XDataDecl x) + , c (XClassDecl x) + , c (XXTyClDecl x) + ) + +-- ------------------------------------- +-- TyClGroup type families +type family XCTyClGroup x +type family XXTyClGroup x + +type ForallXTyClGroup (c :: * -> Constraint) (x :: *) = + ( c (XCTyClGroup x) + , c (XXTyClGroup x) + ) + +-- ------------------------------------- +-- FamilyResultSig type families +type family XNoSig x +type family XCKindSig x -- Clashes with XKindSig above +type family XTyVarSig x +type family XXFamilyResultSig x + +type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) = + ( c (XNoSig x) + , c (XCKindSig x) + , c (XTyVarSig x) + , c (XXFamilyResultSig x) + ) + +-- ------------------------------------- +-- FamilyDecl type families +type family XCFamilyDecl x +type family XXFamilyDecl x + +type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) = + ( c (XCFamilyDecl x) + , c (XXFamilyDecl x) + ) + +-- ------------------------------------- +-- HsDataDefn type families +type family XCHsDataDefn x +type family XXHsDataDefn x + +type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) = + ( c (XCHsDataDefn x) + , c (XXHsDataDefn x) + ) + +-- ------------------------------------- +-- HsDerivingClause type families +type family XCHsDerivingClause x +type family XXHsDerivingClause x + +type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) = + ( c (XCHsDerivingClause x) + , c (XXHsDerivingClause x) + ) + +-- ------------------------------------- +-- ConDecl type families +type family XConDeclGADT x +type family XConDeclH98 x +type family XXConDecl x + +type ForallXConDecl (c :: * -> Constraint) (x :: *) = + ( c (XConDeclGADT x) + , c (XConDeclH98 x) + , c (XXConDecl x) + ) + +-- ------------------------------------- +-- FamEqn type families +type family XCFamEqn x r +type family XXFamEqn x r + +type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) = + ( c (XCFamEqn x r) + , c (XXFamEqn x r) + ) + +-- ------------------------------------- +-- ClsInstDecl type families +type family XCClsInstDecl x +type family XXClsInstDecl x + +type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) = + ( c (XCClsInstDecl x) + , c (XXClsInstDecl x) + ) + +-- ------------------------------------- +-- ClsInstDecl type families +type family XClsInstD x +type family XDataFamInstD x +type family XTyFamInstD x +type family XXInstDecl x + +type ForallXInstDecl (c :: * -> Constraint) (x :: *) = + ( c (XClsInstD x) + , c (XDataFamInstD x) + , c (XTyFamInstD x) + , c (XXInstDecl x) + ) + +-- ------------------------------------- +-- DerivDecl type families +type family XCDerivDecl x +type family XXDerivDecl x + +type ForallXDerivDecl (c :: * -> Constraint) (x :: *) = + ( c (XCDerivDecl x) + , c (XXDerivDecl x) + ) + +-- ------------------------------------- +-- DerivStrategy type family +type family XViaStrategy x + +-- ------------------------------------- +-- DefaultDecl type families +type family XCDefaultDecl x +type family XXDefaultDecl x + +type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) = + ( c (XCDefaultDecl x) + , c (XXDefaultDecl x) + ) + +-- ------------------------------------- +-- DefaultDecl type families +type family XForeignImport x +type family XForeignExport x +type family XXForeignDecl x + +type ForallXForeignDecl (c :: * -> Constraint) (x :: *) = + ( c (XForeignImport x) + , c (XForeignExport x) + , c (XXForeignDecl x) + ) + +-- ------------------------------------- +-- RuleDecls type families +type family XCRuleDecls x +type family XXRuleDecls x + +type ForallXRuleDecls (c :: * -> Constraint) (x :: *) = + ( c (XCRuleDecls x) + , c (XXRuleDecls x) + ) + + +-- ------------------------------------- +-- RuleDecl type families +type family XHsRule x +type family XXRuleDecl x + +type ForallXRuleDecl (c :: * -> Constraint) (x :: *) = + ( c (XHsRule x) + , c (XXRuleDecl x) + ) + +-- ------------------------------------- +-- RuleBndr type families +type family XCRuleBndr x +type family XRuleBndrSig x +type family XXRuleBndr x + +type ForallXRuleBndr (c :: * -> Constraint) (x :: *) = + ( c (XCRuleBndr x) + , c (XRuleBndrSig x) + , c (XXRuleBndr x) + ) + +-- ------------------------------------- +-- WarnDecls type families +type family XWarnings x +type family XXWarnDecls x + +type ForallXWarnDecls (c :: * -> Constraint) (x :: *) = + ( c (XWarnings x) + , c (XXWarnDecls x) + ) + +-- ------------------------------------- +-- AnnDecl type families +type family XWarning x +type family XXWarnDecl x + +type ForallXWarnDecl (c :: * -> Constraint) (x :: *) = + ( c (XWarning x) + , c (XXWarnDecl x) + ) + +-- ------------------------------------- +-- AnnDecl type families +type family XHsAnnotation x +type family XXAnnDecl x + +type ForallXAnnDecl (c :: * -> Constraint) (x :: *) = + ( c (XHsAnnotation x) + , c (XXAnnDecl x) + ) + +-- ------------------------------------- +-- RoleAnnotDecl type families +type family XCRoleAnnotDecl x +type family XXRoleAnnotDecl x + +type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) = + ( c (XCRoleAnnotDecl x) + , c (XXRoleAnnotDecl x) + ) + +-- ===================================================================== +-- Type families for the HsExpr extension points + +type family XVar x +type family XUnboundVar x +type family XConLikeOut x +type family XRecFld x +type family XOverLabel x +type family XIPVar x +type family XOverLitE x +type family XLitE x +type family XLam x +type family XLamCase x +type family XApp x +type family XAppTypeE x +type family XOpApp x +type family XNegApp x +type family XPar x +type family XSectionL x +type family XSectionR x +type family XExplicitTuple x +type family XExplicitSum x +type family XCase x +type family XIf x +type family XMultiIf x +type family XLet x +type family XDo x +type family XExplicitList x +type family XRecordCon x +type family XRecordUpd x +type family XExprWithTySig x +type family XArithSeq x +type family XSCC x +type family XCoreAnn x +type family XBracket x +type family XRnBracketOut x +type family XTcBracketOut x +type family XSpliceE x +type family XProc x +type family XStatic x +type family XTick x +type family XBinTick x +type family XTickPragma x +type family XWrap x +type family XXExpr x + +type ForallXExpr (c :: * -> Constraint) (x :: *) = + ( c (XVar x) + , c (XUnboundVar x) + , c (XConLikeOut x) + , c (XRecFld x) + , c (XOverLabel x) + , c (XIPVar x) + , c (XOverLitE x) + , c (XLitE x) + , c (XLam x) + , c (XLamCase x) + , c (XApp x) + , c (XAppTypeE x) + , c (XOpApp x) + , c (XNegApp x) + , c (XPar x) + , c (XSectionL x) + , c (XSectionR x) + , c (XExplicitTuple x) + , c (XExplicitSum x) + , c (XCase x) + , c (XIf x) + , c (XMultiIf x) + , c (XLet x) + , c (XDo x) + , c (XExplicitList x) + , c (XRecordCon x) + , c (XRecordUpd x) + , c (XExprWithTySig x) + , c (XArithSeq x) + , c (XSCC x) + , c (XCoreAnn x) + , c (XBracket x) + , c (XRnBracketOut x) + , c (XTcBracketOut x) + , c (XSpliceE x) + , c (XProc x) + , c (XStatic x) + , c (XTick x) + , c (XBinTick x) + , c (XTickPragma x) + , c (XWrap x) + , c (XXExpr x) + ) +-- --------------------------------------------------------------------- + +type family XUnambiguous x +type family XAmbiguous x +type family XXAmbiguousFieldOcc x + +type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XUnambiguous x) + , c (XAmbiguous x) + , c (XXAmbiguousFieldOcc x) + ) + +-- ---------------------------------------------------------------------- + +type family XPresent x +type family XMissing x +type family XXTupArg x + +type ForallXTupArg (c :: * -> Constraint) (x :: *) = + ( c (XPresent x) + , c (XMissing x) + , c (XXTupArg x) + ) + +-- --------------------------------------------------------------------- + +type family XTypedSplice x +type family XUntypedSplice x +type family XQuasiQuote x +type family XSpliced x +type family XXSplice x + +type ForallXSplice (c :: * -> Constraint) (x :: *) = + ( c (XTypedSplice x) + , c (XUntypedSplice x) + , c (XQuasiQuote x) + , c (XSpliced x) + , c (XXSplice x) + ) + +-- --------------------------------------------------------------------- + +type family XExpBr x +type family XPatBr x +type family XDecBrL x +type family XDecBrG x +type family XTypBr x +type family XVarBr x +type family XTExpBr x +type family XXBracket x + +type ForallXBracket (c :: * -> Constraint) (x :: *) = + ( c (XExpBr x) + , c (XPatBr x) + , c (XDecBrL x) + , c (XDecBrG x) + , c (XTypBr x) + , c (XVarBr x) + , c (XTExpBr x) + , c (XXBracket x) + ) + +-- --------------------------------------------------------------------- + +type family XCmdTop x +type family XXCmdTop x + +type ForallXCmdTop (c :: * -> Constraint) (x :: *) = + ( c (XCmdTop x) + , c (XXCmdTop x) + ) + +-- ------------------------------------- + +type family XMG x b +type family XXMatchGroup x b + +type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XMG x b) + , c (XXMatchGroup x b) + ) + +-- ------------------------------------- + +type family XCMatch x b +type family XXMatch x b + +type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCMatch x b) + , c (XXMatch x b) + ) + +-- ------------------------------------- + +type family XCGRHSs x b +type family XXGRHSs x b + +type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCGRHSs x b) + , c (XXGRHSs x b) + ) + +-- ------------------------------------- + +type family XCGRHS x b +type family XXGRHS x b + +type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCGRHS x b) + , c (XXGRHS x b) + ) + +-- ------------------------------------- + +type family XLastStmt x x' b +type family XBindStmt x x' b +type family XApplicativeStmt x x' b +type family XBodyStmt x x' b +type family XLetStmt x x' b +type family XParStmt x x' b +type family XTransStmt x x' b +type family XRecStmt x x' b +type family XXStmtLR x x' b + +type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) = + ( c (XLastStmt x x' b) + , c (XBindStmt x x' b) + , c (XApplicativeStmt x x' b) + , c (XBodyStmt x x' b) + , c (XLetStmt x x' b) + , c (XParStmt x x' b) + , c (XTransStmt x x' b) + , c (XRecStmt x x' b) + , c (XXStmtLR x x' b) + ) + +-- --------------------------------------------------------------------- + +type family XCmdArrApp x +type family XCmdArrForm x +type family XCmdApp x +type family XCmdLam x +type family XCmdPar x +type family XCmdCase x +type family XCmdIf x +type family XCmdLet x +type family XCmdDo x +type family XCmdWrap x +type family XXCmd x + +type ForallXCmd (c :: * -> Constraint) (x :: *) = + ( c (XCmdArrApp x) + , c (XCmdArrForm x) + , c (XCmdApp x) + , c (XCmdLam x) + , c (XCmdPar x) + , c (XCmdCase x) + , c (XCmdIf x) + , c (XCmdLet x) + , c (XCmdDo x) + , c (XCmdWrap x) + , c (XXCmd x) + ) + +-- --------------------------------------------------------------------- + +type family XParStmtBlock x x' +type family XXParStmtBlock x x' + +type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XParStmtBlock x x') + , c (XXParStmtBlock x x') + ) + +-- --------------------------------------------------------------------- + +type family XApplicativeArgOne x +type family XApplicativeArgMany x +type family XXApplicativeArg x + +type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) = + ( c (XApplicativeArgOne x) + , c (XApplicativeArgMany x) + , c (XXApplicativeArg x) + ) + +-- ===================================================================== +-- Type families for the HsImpExp extension points + +-- TODO + +-- ===================================================================== +-- Type families for the HsLit extension points + +-- We define a type family for each extension point. This is based on prepending +-- 'X' to the constructor name, for ease of reference. +type family XHsChar x +type family XHsCharPrim x +type family XHsString x +type family XHsStringPrim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt64Prim x +type family XHsWord64Prim x +type family XHsInteger x +type family XHsRat x +type family XHsFloatPrim x +type family XHsDoublePrim x +type family XXLit x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallXHsLit (c :: * -> Constraint) (x :: *) = + ( c (XHsChar x) + , c (XHsCharPrim x) + , c (XHsDoublePrim x) + , c (XHsFloatPrim x) + , c (XHsInt x) + , c (XHsInt64Prim x) + , c (XHsIntPrim x) + , c (XHsInteger x) + , c (XHsRat x) + , c (XHsString x) + , c (XHsStringPrim x) + , c (XHsWord64Prim x) + , c (XHsWordPrim x) + , c (XXLit x) + ) + +type family XOverLit x +type family XXOverLit x + +type ForallXOverLit (c :: * -> Constraint) (x :: *) = + ( c (XOverLit x) + , c (XXOverLit x) + ) + +-- ===================================================================== +-- Type families for the HsPat extension points + +type family XWildPat x +type family XVarPat x +type family XLazyPat x +type family XAsPat x +type family XParPat x +type family XBangPat x +type family XListPat x +type family XTuplePat x +type family XSumPat x +type family XConPat x +type family XViewPat x +type family XSplicePat x +type family XLitPat x +type family XNPat x +type family XNPlusKPat x +type family XSigPat x +type family XCoPat x +type family XXPat x + + +type ForallXPat (c :: * -> Constraint) (x :: *) = + ( c (XWildPat x) + , c (XVarPat x) + , c (XLazyPat x) + , c (XAsPat x) + , c (XParPat x) + , c (XBangPat x) + , c (XListPat x) + , c (XTuplePat x) + , c (XSumPat x) + , c (XViewPat x) + , c (XSplicePat x) + , c (XLitPat x) + , c (XNPat x) + , c (XNPlusKPat x) + , c (XSigPat x) + , c (XCoPat x) + , c (XXPat x) + ) + +-- ===================================================================== +-- Type families for the HsTypes type families + +type family XHsQTvs x +type family XXLHsQTyVars x + +type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) = + ( c (XHsQTvs x) + , c (XXLHsQTyVars x) + ) + +-- ------------------------------------- + +type family XHsIB x b +type family XXHsImplicitBndrs x b + +type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XHsIB x b) + , c (XXHsImplicitBndrs x b) + ) + +-- ------------------------------------- + +type family XHsWC x b +type family XXHsWildCardBndrs x b + +type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XHsWC x b) + , c (XXHsWildCardBndrs x b) + ) + +-- ------------------------------------- + +type family XForAllTy x +type family XQualTy x +type family XTyVar x +type family XAppTy x +type family XAppKindTy x +type family XFunTy x +type family XListTy x +type family XTupleTy x +type family XSumTy x +type family XOpTy x +type family XParTy x +type family XIParamTy x +type family XStarTy x +type family XKindSig x +type family XSpliceTy x +type family XDocTy x +type family XBangTy x +type family XRecTy x +type family XExplicitListTy x +type family XExplicitTupleTy x +type family XTyLit x +type family XWildCardTy x +type family XXType x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallXType (c :: * -> Constraint) (x :: *) = + ( c (XForAllTy x) + , c (XQualTy x) + , c (XTyVar x) + , c (XAppTy x) + , c (XAppKindTy x) + , c (XFunTy x) + , c (XListTy x) + , c (XTupleTy x) + , c (XSumTy x) + , c (XOpTy x) + , c (XParTy x) + , c (XIParamTy x) + , c (XStarTy x) + , c (XKindSig x) + , c (XSpliceTy x) + , c (XDocTy x) + , c (XBangTy x) + , c (XRecTy x) + , c (XExplicitListTy x) + , c (XExplicitTupleTy x) + , c (XTyLit x) + , c (XWildCardTy x) + , c (XXType x) + ) + +-- --------------------------------------------------------------------- + +type family XUserTyVar x +type family XKindedTyVar x +type family XXTyVarBndr x + +type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = + ( c (XUserTyVar x) + , c (XKindedTyVar x) + , c (XXTyVarBndr x) + ) + +-- --------------------------------------------------------------------- + +type family XConDeclField x +type family XXConDeclField x + +type ForallXConDeclField (c :: * -> Constraint) (x :: *) = + ( c (XConDeclField x) + , c (XXConDeclField x) + ) + +-- --------------------------------------------------------------------- + +type family XCFieldOcc x +type family XXFieldOcc x + +type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XCFieldOcc x) + , c (XXFieldOcc x) + ) + + +-- ===================================================================== +-- Type families for the HsImpExp type families + +type family XCImportDecl x +type family XXImportDecl x + +type ForallXImportDecl (c :: * -> Constraint) (x :: *) = + ( c (XCImportDecl x) + , c (XXImportDecl x) + ) + +-- ------------------------------------- + +type family XIEVar x +type family XIEThingAbs x +type family XIEThingAll x +type family XIEThingWith x +type family XIEModuleContents x +type family XIEGroup x +type family XIEDoc x +type family XIEDocNamed x +type family XXIE x + +type ForallXIE (c :: * -> Constraint) (x :: *) = + ( c (XIEVar x) + , c (XIEThingAbs x) + , c (XIEThingAll x) + , c (XIEThingWith x) + , c (XIEModuleContents x) + , c (XIEGroup x) + , c (XIEDoc x) + , c (XIEDocNamed x) + , c (XXIE x) + ) + +-- ------------------------------------- + + +-- ===================================================================== +-- End of Type family definitions +-- ===================================================================== + +-- ---------------------------------------------------------------------- +-- | Conversion of annotations from one type index to another. This is required +-- where the AST is converted from one pass to another, and the extension values +-- need to be brought along if possible. So for example a 'SourceText' is +-- converted via 'id', but needs a type signature to keep the type checker +-- happy. +class Convertable a b | a -> b where + convert :: a -> b + +instance Convertable a a where + convert = id + +-- | A constraint capturing all the extension points that can be converted via +-- @instance Convertable a a@ +type ConvertIdX a b = + (XHsDoublePrim a ~ XHsDoublePrim b, + XHsFloatPrim a ~ XHsFloatPrim b, + XHsRat a ~ XHsRat b, + XHsInteger a ~ XHsInteger b, + XHsWord64Prim a ~ XHsWord64Prim b, + XHsInt64Prim a ~ XHsInt64Prim b, + XHsWordPrim a ~ XHsWordPrim b, + XHsIntPrim a ~ XHsIntPrim b, + XHsInt a ~ XHsInt b, + XHsStringPrim a ~ XHsStringPrim b, + XHsString a ~ XHsString b, + XHsCharPrim a ~ XHsCharPrim b, + XHsChar a ~ XHsChar b, + XXLit a ~ XXLit b) + +-- ---------------------------------------------------------------------- + +-- Note [OutputableX] +-- ~~~~~~~~~~~~~~~~~~ +-- +-- is required because the type family resolution +-- process cannot determine that all cases are handled for a `GhcPass p` +-- case where the cases are listed separately. +-- +-- So +-- +-- type instance XXHsIPBinds (GhcPass p) = NoExtCon +-- +-- will correctly deduce Outputable for (GhcPass p), but +-- +-- type instance XIPBinds GhcPs = NoExt +-- type instance XIPBinds GhcRn = NoExt +-- type instance XIPBinds GhcTc = TcEvBinds +-- +-- will not. + + +-- | Provide a summary constraint that gives all am Outputable constraint to +-- extension points needing one +type OutputableX p = -- See Note [OutputableX] + ( Outputable (XIPBinds p) + , Outputable (XViaStrategy p) + , Outputable (XViaStrategy GhcRn) + ) +-- TODO: Should OutputableX be included in OutputableBndrId? + +-- ---------------------------------------------------------------------- + +-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both +-- the @id@ and the 'NameOrRdrName' type for it +type OutputableBndrId id = + ( OutputableBndr (NameOrRdrName (IdP id)) + , OutputableBndr (IdP id) + , OutputableBndr (NameOrRdrName (IdP (NoGhcTc id))) + , OutputableBndr (IdP (NoGhcTc id)) + , NoGhcTc id ~ NoGhcTc (NoGhcTc id) + , OutputableX id + , OutputableX (NoGhcTc id) + ) diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs new file mode 100644 index 0000000000..56d1691ac4 --- /dev/null +++ b/compiler/GHC/Hs/ImpExp.hs @@ -0,0 +1,366 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder + +module GHC.Hs.ImpExp where + +import GhcPrelude + +import Module ( ModuleName ) +import GHC.Hs.Doc ( HsDocString ) +import OccName ( HasOccName(..), isTcOcc, isSymOcc ) +import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) +import FieldLabel ( FieldLbl(..) ) + +import Outputable +import FastString +import SrcLoc +import GHC.Hs.Extension + +import Data.Data +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Import and export declaration lists} +* * +************************************************************************ + +One per \tr{import} declaration in a module. +-} + +-- | Located Import Declaration +type LImportDecl pass = Located (ImportDecl pass) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | If/how an import is 'qualified'. +data ImportDeclQualifiedStyle + = QualifiedPre -- ^ 'qualified' appears in prepositive position. + | QualifiedPost -- ^ 'qualified' appears in postpositive position. + | NotQualified -- ^ Not qualified. + deriving (Eq, Data) + +-- | Given two possible located 'qualified' tokens, compute a style +-- (in a conforming Haskell program only one of the two can be not +-- 'Nothing'). This is called from 'Parser.y'. +importDeclQualifiedStyle :: Maybe (Located a) + -> Maybe (Located a) + -> ImportDeclQualifiedStyle +importDeclQualifiedStyle mPre mPost = + if isJust mPre then QualifiedPre + else if isJust mPost then QualifiedPost else NotQualified + +-- | Convenience function to answer the question if an import decl. is +-- qualified. +isImportDeclQualified :: ImportDeclQualifiedStyle -> Bool +isImportDeclQualified NotQualified = False +isImportDeclQualified _ = True + +-- | Import Declaration +-- +-- A single Haskell @import@ declaration. +data ImportDecl pass + = ImportDecl { + ideclExt :: XCImportDecl pass, + ideclSourceSrc :: SourceText, + -- Note [Pragma source text] in BasicTypes + ideclName :: Located ModuleName, -- ^ Module name. + ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. + ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import + ideclSafe :: Bool, -- ^ True => safe import + ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. + ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) + ideclAs :: Maybe (Located ModuleName), -- ^ as Module + ideclHiding :: Maybe (Bool, Located [LIE pass]) + -- ^ (True => hiding, names) + } + | XImportDecl (XXImportDecl pass) + -- ^ + -- 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnImport' + -- + -- - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource + -- + -- - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified', + -- 'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs', + -- 'ApiAnnotation.AnnVal' + -- + -- - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' attached + -- to location in ideclHiding + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XCImportDecl (GhcPass _) = NoExtField +type instance XXImportDecl (GhcPass _) = NoExtCon + +simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p) +simpleImportDecl mn = ImportDecl { + ideclExt = noExtField, + ideclSourceSrc = NoSourceText, + ideclName = noLoc mn, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, + ideclImplicit = False, + ideclQualified = NotQualified, + ideclAs = Nothing, + ideclHiding = Nothing + } + +instance (p ~ GhcPass pass,OutputableBndrId p) + => Outputable (ImportDecl p) where + ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' + , ideclPkgQual = pkg + , ideclSource = from, ideclSafe = safe + , ideclQualified = qual, ideclImplicit = implicit + , ideclAs = as, ideclHiding = spec }) + = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe, + pp_qual qual False, pp_pkg pkg, ppr mod', pp_qual qual True, pp_as as]) + 4 (pp_spec spec) + where + pp_implicit False = empty + pp_implicit True = ptext (sLit ("(implicit)")) + + pp_pkg Nothing = empty + pp_pkg (Just (StringLiteral st p)) + = pprWithSourceText st (doubleQuotes (ftext p)) + + pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. + pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position. + pp_qual QualifiedPre True = empty -- Prepositive qualifier/postpositive position. + pp_qual QualifiedPost False = empty -- Postpositive qualifier/prepositive position. + pp_qual NotQualified _ = empty + + pp_safe False = empty + pp_safe True = text "safe" + + pp_as Nothing = empty + pp_as (Just a) = text "as" <+> ppr a + + ppr_imp True = case mSrcText of + NoSourceText -> text "{-# SOURCE #-}" + SourceText src -> text src <+> text "#-}" + ppr_imp False = empty + + pp_spec Nothing = empty + pp_spec (Just (False, (L _ ies))) = ppr_ies ies + pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies + + ppr_ies [] = text "()" + ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' + ppr (XImportDecl x) = ppr x + +{- +************************************************************************ +* * +\subsection{Imported and exported entities} +* * +************************************************************************ +-} + +-- | A name in an import or export specification which may have adornments. Used +-- primarily for accurate pretty printing of ParsedSource, and API Annotation +-- placement. +data IEWrappedName name + = IEName (Located name) -- ^ no extra + | IEPattern (Located name) -- ^ pattern X + | IEType (Located name) -- ^ type (:+:) + deriving (Eq,Data) + +-- | Located name with possible adornment +-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType', +-- 'ApiAnnotation.AnnPattern' +type LIEWrappedName name = Located (IEWrappedName name) +-- For details on above see note [Api annotations] in ApiAnnotation + + +-- | Located Import or Export +type LIE pass = Located (IE pass) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | Imported or exported entity. +data IE pass + = IEVar (XIEVar pass) (LIEWrappedName (IdP pass)) + -- ^ Imported or Exported Variable + + | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass)) + -- ^ Imported or exported Thing with Absent list + -- + -- The thing is a Class/Type (can't tell) + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnVal' + + -- For details on above see note [Api annotations] in ApiAnnotation + -- See Note [Located RdrNames] in GHC.Hs.Expr + | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass)) + -- ^ Imported or exported Thing with All imported or exported + -- + -- The thing is a Class/Type and the All refers to methods/constructors + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnType' + + -- For details on above see note [Api annotations] in ApiAnnotation + -- See Note [Located RdrNames] in GHC.Hs.Expr + + | IEThingWith (XIEThingWith pass) + (LIEWrappedName (IdP pass)) + IEWildcard + [LIEWrappedName (IdP pass)] + [Located (FieldLbl (IdP pass))] + -- ^ Imported or exported Thing With given imported or exported + -- + -- The thing is a Class/Type and the imported or exported things are + -- methods/constructors and record fields; see Note [IEThingWith] + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnComma', + -- 'ApiAnnotation.AnnType' + + -- For details on above see note [Api annotations] in ApiAnnotation + | IEModuleContents (XIEModuleContents pass) (Located ModuleName) + -- ^ Imported or exported module contents + -- + -- (Export Only) + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule' + + -- For details on above see note [Api annotations] in ApiAnnotation + | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading + | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation + | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc + | XIE (XXIE pass) + +type instance XIEVar (GhcPass _) = NoExtField +type instance XIEThingAbs (GhcPass _) = NoExtField +type instance XIEThingAll (GhcPass _) = NoExtField +type instance XIEThingWith (GhcPass _) = NoExtField +type instance XIEModuleContents (GhcPass _) = NoExtField +type instance XIEGroup (GhcPass _) = NoExtField +type instance XIEDoc (GhcPass _) = NoExtField +type instance XIEDocNamed (GhcPass _) = NoExtField +type instance XXIE (GhcPass _) = NoExtCon + +-- | Imported or Exported Wildcard +data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) + +{- +Note [IEThingWith] +~~~~~~~~~~~~~~~~~~ + +A definition like + + module M ( T(MkT, x) ) where + data T = MkT { x :: Int } + +gives rise to + + IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) + IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) + +See Note [Representing fields in AvailInfo] in Avail for more details. +-} + +ieName :: IE (GhcPass p) -> IdP (GhcPass p) +ieName (IEVar _ (L _ n)) = ieWrappedName n +ieName (IEThingAbs _ (L _ n)) = ieWrappedName n +ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n +ieName (IEThingAll _ (L _ n)) = ieWrappedName n +ieName _ = panic "ieName failed pattern match!" + +ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] +ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n + : map (ieWrappedName . unLoc) ns +ieNames (IEModuleContents {}) = [] +ieNames (IEGroup {}) = [] +ieNames (IEDoc {}) = [] +ieNames (IEDocNamed {}) = [] +ieNames (XIE nec) = noExtCon nec + +ieWrappedName :: IEWrappedName name -> name +ieWrappedName (IEName (L _ n)) = n +ieWrappedName (IEPattern (L _ n)) = n +ieWrappedName (IEType (L _ n)) = n + +lieWrappedName :: LIEWrappedName name -> name +lieWrappedName (L _ n) = ieWrappedName n + +ieLWrappedName :: LIEWrappedName name -> Located name +ieLWrappedName (L l n) = L l (ieWrappedName n) + +replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 +replaceWrappedName (IEName (L l _)) n = IEName (L l n) +replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n) +replaceWrappedName (IEType (L l _)) n = IEType (L l n) + +replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 +replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') + +instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where + ppr (IEVar _ var) = ppr (unLoc var) + ppr (IEThingAbs _ thing) = ppr (unLoc thing) + ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] + ppr (IEThingWith _ thing wc withs flds) + = ppr (unLoc thing) <> parens (fsep (punctuate comma + (ppWiths ++ + map (ppr . flLabel . unLoc) flds))) + where + ppWiths = + case wc of + NoIEWildcard -> + map (ppr . unLoc) withs + IEWildcard pos -> + let (bs, as) = splitAt pos (map (ppr . unLoc) withs) + in bs ++ [text ".."] ++ as + ppr (IEModuleContents _ mod') + = text "module" <+> ppr mod' + ppr (IEGroup _ n _) = text ("") + ppr (IEDoc _ doc) = ppr doc + ppr (IEDocNamed _ string) = text ("") + ppr (XIE x) = ppr x + +instance (HasOccName name) => HasOccName (IEWrappedName name) where + occName w = occName (ieWrappedName w) + +instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where + pprBndr bs w = pprBndr bs (ieWrappedName w) + pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) + pprInfixOcc w = pprInfixOcc (ieWrappedName w) + +instance (OutputableBndr name) => Outputable (IEWrappedName name) where + ppr (IEName n) = pprPrefixOcc (unLoc n) + ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n) + ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n) + +pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc +pprImpExp name = type_pref <+> pprPrefixOcc name + where + occ = occName name + type_pref | isTcOcc occ && isSymOcc occ = text "type" + | otherwise = empty diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs new file mode 100644 index 0000000000..d55e20c2e7 --- /dev/null +++ b/compiler/GHC/Hs/Instances.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GHC.Hs.Instances where + +-- This module defines the Data instances for the hsSyn AST. + +-- It happens here to avoid massive constraint types on the AST with concomitant +-- slow GHC bootstrap times. + +-- UndecidableInstances ? + +import Data.Data hiding ( Fixity ) + +import GhcPrelude +import GHC.Hs.Extension +import GHC.Hs.Binds +import GHC.Hs.Decls +import GHC.Hs.Expr +import GHC.Hs.Lit +import GHC.Hs.Types +import GHC.Hs.Pat +import GHC.Hs.ImpExp + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs----------------------------------------- + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Binds ---------------------------------- + +-- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR) +deriving instance Data (HsLocalBindsLR GhcPs GhcPs) +deriving instance Data (HsLocalBindsLR GhcPs GhcRn) +deriving instance Data (HsLocalBindsLR GhcRn GhcRn) +deriving instance Data (HsLocalBindsLR GhcTc GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR) +deriving instance Data (HsValBindsLR GhcPs GhcPs) +deriving instance Data (HsValBindsLR GhcPs GhcRn) +deriving instance Data (HsValBindsLR GhcRn GhcRn) +deriving instance Data (HsValBindsLR GhcTc GhcTc) + +-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) +deriving instance Data (NHsValBindsLR GhcPs) +deriving instance Data (NHsValBindsLR GhcRn) +deriving instance Data (NHsValBindsLR GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR) +deriving instance Data (HsBindLR GhcPs GhcPs) +deriving instance Data (HsBindLR GhcPs GhcRn) +deriving instance Data (HsBindLR GhcRn GhcRn) +deriving instance Data (HsBindLR GhcTc GhcTc) + +-- deriving instance (DataId p) => Data (ABExport p) +deriving instance Data (ABExport GhcPs) +deriving instance Data (ABExport GhcRn) +deriving instance Data (ABExport GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) +deriving instance Data (PatSynBind GhcPs GhcPs) +deriving instance Data (PatSynBind GhcPs GhcRn) +deriving instance Data (PatSynBind GhcRn GhcRn) +deriving instance Data (PatSynBind GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsIPBinds p) +deriving instance Data (HsIPBinds GhcPs) +deriving instance Data (HsIPBinds GhcRn) +deriving instance Data (HsIPBinds GhcTc) + +-- deriving instance (DataIdLR p p) => Data (IPBind p) +deriving instance Data (IPBind GhcPs) +deriving instance Data (IPBind GhcRn) +deriving instance Data (IPBind GhcTc) + +-- deriving instance (DataIdLR p p) => Data (Sig p) +deriving instance Data (Sig GhcPs) +deriving instance Data (Sig GhcRn) +deriving instance Data (Sig GhcTc) + +-- deriving instance (DataId p) => Data (FixitySig p) +deriving instance Data (FixitySig GhcPs) +deriving instance Data (FixitySig GhcRn) +deriving instance Data (FixitySig GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsPatSynDir p) +deriving instance Data (HsPatSynDir GhcPs) +deriving instance Data (HsPatSynDir GhcRn) +deriving instance Data (HsPatSynDir GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Decls ---------------------------------- + +-- deriving instance (DataIdLR p p) => Data (HsDecl p) +deriving instance Data (HsDecl GhcPs) +deriving instance Data (HsDecl GhcRn) +deriving instance Data (HsDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsGroup p) +deriving instance Data (HsGroup GhcPs) +deriving instance Data (HsGroup GhcRn) +deriving instance Data (HsGroup GhcTc) + +-- deriving instance (DataIdLR p p) => Data (SpliceDecl p) +deriving instance Data (SpliceDecl GhcPs) +deriving instance Data (SpliceDecl GhcRn) +deriving instance Data (SpliceDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (TyClDecl p) +deriving instance Data (TyClDecl GhcPs) +deriving instance Data (TyClDecl GhcRn) +deriving instance Data (TyClDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (TyClGroup p) +deriving instance Data (TyClGroup GhcPs) +deriving instance Data (TyClGroup GhcRn) +deriving instance Data (TyClGroup GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyResultSig p) +deriving instance Data (FamilyResultSig GhcPs) +deriving instance Data (FamilyResultSig GhcRn) +deriving instance Data (FamilyResultSig GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyDecl p) +deriving instance Data (FamilyDecl GhcPs) +deriving instance Data (FamilyDecl GhcRn) +deriving instance Data (FamilyDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (InjectivityAnn p) +deriving instance Data (InjectivityAnn GhcPs) +deriving instance Data (InjectivityAnn GhcRn) +deriving instance Data (InjectivityAnn GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyInfo p) +deriving instance Data (FamilyInfo GhcPs) +deriving instance Data (FamilyInfo GhcRn) +deriving instance Data (FamilyInfo GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsDataDefn p) +deriving instance Data (HsDataDefn GhcPs) +deriving instance Data (HsDataDefn GhcRn) +deriving instance Data (HsDataDefn GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsDerivingClause p) +deriving instance Data (HsDerivingClause GhcPs) +deriving instance Data (HsDerivingClause GhcRn) +deriving instance Data (HsDerivingClause GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ConDecl p) +deriving instance Data (ConDecl GhcPs) +deriving instance Data (ConDecl GhcRn) +deriving instance Data (ConDecl GhcTc) + +-- deriving instance DataIdLR p p => Data (TyFamInstDecl p) +deriving instance Data (TyFamInstDecl GhcPs) +deriving instance Data (TyFamInstDecl GhcRn) +deriving instance Data (TyFamInstDecl GhcTc) + +-- deriving instance DataIdLR p p => Data (DataFamInstDecl p) +deriving instance Data (DataFamInstDecl GhcPs) +deriving instance Data (DataFamInstDecl GhcRn) +deriving instance Data (DataFamInstDecl GhcTc) + +-- deriving instance (DataIdLR p p,Data rhs)=>Data (FamEqn p rhs) +deriving instance Data rhs => Data (FamEqn GhcPs rhs) +deriving instance Data rhs => Data (FamEqn GhcRn rhs) +deriving instance Data rhs => Data (FamEqn GhcTc rhs) + +-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p) +deriving instance Data (ClsInstDecl GhcPs) +deriving instance Data (ClsInstDecl GhcRn) +deriving instance Data (ClsInstDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (InstDecl p) +deriving instance Data (InstDecl GhcPs) +deriving instance Data (InstDecl GhcRn) +deriving instance Data (InstDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DerivDecl p) +deriving instance Data (DerivDecl GhcPs) +deriving instance Data (DerivDecl GhcRn) +deriving instance Data (DerivDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DerivStrategy p) +deriving instance Data (DerivStrategy GhcPs) +deriving instance Data (DerivStrategy GhcRn) +deriving instance Data (DerivStrategy GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DefaultDecl p) +deriving instance Data (DefaultDecl GhcPs) +deriving instance Data (DefaultDecl GhcRn) +deriving instance Data (DefaultDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ForeignDecl p) +deriving instance Data (ForeignDecl GhcPs) +deriving instance Data (ForeignDecl GhcRn) +deriving instance Data (ForeignDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleDecls p) +deriving instance Data (RuleDecls GhcPs) +deriving instance Data (RuleDecls GhcRn) +deriving instance Data (RuleDecls GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleDecl p) +deriving instance Data (RuleDecl GhcPs) +deriving instance Data (RuleDecl GhcRn) +deriving instance Data (RuleDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleBndr p) +deriving instance Data (RuleBndr GhcPs) +deriving instance Data (RuleBndr GhcRn) +deriving instance Data (RuleBndr GhcTc) + +-- deriving instance (DataId p) => Data (WarnDecls p) +deriving instance Data (WarnDecls GhcPs) +deriving instance Data (WarnDecls GhcRn) +deriving instance Data (WarnDecls GhcTc) + +-- deriving instance (DataId p) => Data (WarnDecl p) +deriving instance Data (WarnDecl GhcPs) +deriving instance Data (WarnDecl GhcRn) +deriving instance Data (WarnDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (AnnDecl p) +deriving instance Data (AnnDecl GhcPs) +deriving instance Data (AnnDecl GhcRn) +deriving instance Data (AnnDecl GhcTc) + +-- deriving instance (DataId p) => Data (RoleAnnotDecl p) +deriving instance Data (RoleAnnotDecl GhcPs) +deriving instance Data (RoleAnnotDecl GhcRn) +deriving instance Data (RoleAnnotDecl GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Expr ----------------------------------- + +-- deriving instance (DataIdLR p p) => Data (SyntaxExpr p) +deriving instance Data (SyntaxExpr GhcPs) +deriving instance Data (SyntaxExpr GhcRn) +deriving instance Data (SyntaxExpr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsExpr p) +deriving instance Data (HsExpr GhcPs) +deriving instance Data (HsExpr GhcRn) +deriving instance Data (HsExpr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsTupArg p) +deriving instance Data (HsTupArg GhcPs) +deriving instance Data (HsTupArg GhcRn) +deriving instance Data (HsTupArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsCmd p) +deriving instance Data (HsCmd GhcPs) +deriving instance Data (HsCmd GhcRn) +deriving instance Data (HsCmd GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsCmdTop p) +deriving instance Data (HsCmdTop GhcPs) +deriving instance Data (HsCmdTop GhcRn) +deriving instance Data (HsCmdTop GhcTc) + +-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body) +deriving instance (Data body) => Data (MatchGroup GhcPs body) +deriving instance (Data body) => Data (MatchGroup GhcRn body) +deriving instance (Data body) => Data (MatchGroup GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (Match p body) +deriving instance (Data body) => Data (Match GhcPs body) +deriving instance (Data body) => Data (Match GhcRn body) +deriving instance (Data body) => Data (Match GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body) +deriving instance (Data body) => Data (GRHSs GhcPs body) +deriving instance (Data body) => Data (GRHSs GhcRn body) +deriving instance (Data body) => Data (GRHSs GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body) +deriving instance (Data body) => Data (GRHS GhcPs body) +deriving instance (Data body) => Data (GRHS GhcRn body) +deriving instance (Data body) => Data (GRHS GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body) +deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body) +deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body) +deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body) +deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body) + +deriving instance Data RecStmtTc + +-- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p) +deriving instance Data (ParStmtBlock GhcPs GhcPs) +deriving instance Data (ParStmtBlock GhcPs GhcRn) +deriving instance Data (ParStmtBlock GhcRn GhcRn) +deriving instance Data (ParStmtBlock GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) +deriving instance Data (ApplicativeArg GhcPs) +deriving instance Data (ApplicativeArg GhcRn) +deriving instance Data (ApplicativeArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsSplice p) +deriving instance Data (HsSplice GhcPs) +deriving instance Data (HsSplice GhcRn) +deriving instance Data (HsSplice GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsSplicedThing p) +deriving instance Data (HsSplicedThing GhcPs) +deriving instance Data (HsSplicedThing GhcRn) +deriving instance Data (HsSplicedThing GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsBracket p) +deriving instance Data (HsBracket GhcPs) +deriving instance Data (HsBracket GhcRn) +deriving instance Data (HsBracket GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p) +deriving instance Data (ArithSeqInfo GhcPs) +deriving instance Data (ArithSeqInfo GhcRn) +deriving instance Data (ArithSeqInfo GhcTc) + +deriving instance Data RecordConTc +deriving instance Data CmdTopTc +deriving instance Data PendingRnSplice +deriving instance Data PendingTcSplice + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Lit ------------------------------------ + +-- deriving instance (DataId p) => Data (HsLit p) +deriving instance Data (HsLit GhcPs) +deriving instance Data (HsLit GhcRn) +deriving instance Data (HsLit GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsOverLit p) +deriving instance Data (HsOverLit GhcPs) +deriving instance Data (HsOverLit GhcRn) +deriving instance Data (HsOverLit GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Pat ------------------------------------ + +-- deriving instance (DataIdLR p p) => Data (Pat p) +deriving instance Data (Pat GhcPs) +deriving instance Data (Pat GhcRn) +deriving instance Data (Pat GhcTc) + +deriving instance Data ListPatTc + +-- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) +deriving instance (Data body) => Data (HsRecFields GhcPs body) +deriving instance (Data body) => Data (HsRecFields GhcRn body) +deriving instance (Data body) => Data (HsRecFields GhcTc body) + +-- --------------------------------------------------------------------- +-- Data derivations from GHC.Hs.Types ---------------------------------- + +-- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) +deriving instance Data (LHsQTyVars GhcPs) +deriving instance Data (LHsQTyVars GhcRn) +deriving instance Data (LHsQTyVars GhcTc) + +-- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing) + +-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) + +-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) +deriving instance Data (HsTyVarBndr GhcPs) +deriving instance Data (HsTyVarBndr GhcRn) +deriving instance Data (HsTyVarBndr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsType p) +deriving instance Data (HsType GhcPs) +deriving instance Data (HsType GhcRn) +deriving instance Data (HsType GhcTc) + +deriving instance Data (LHsTypeArg GhcPs) +deriving instance Data (LHsTypeArg GhcRn) +deriving instance Data (LHsTypeArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ConDeclField p) +deriving instance Data (ConDeclField GhcPs) +deriving instance Data (ConDeclField GhcRn) +deriving instance Data (ConDeclField GhcTc) + +-- deriving instance (DataId p) => Data (FieldOcc p) +deriving instance Data (FieldOcc GhcPs) +deriving instance Data (FieldOcc GhcRn) +deriving instance Data (FieldOcc GhcTc) + +-- deriving instance DataId p => Data (AmbiguousFieldOcc p) +deriving instance Data (AmbiguousFieldOcc GhcPs) +deriving instance Data (AmbiguousFieldOcc GhcRn) +deriving instance Data (AmbiguousFieldOcc GhcTc) + + +-- deriving instance (DataId name) => Data (ImportDecl name) +deriving instance Data (ImportDecl GhcPs) +deriving instance Data (ImportDecl GhcRn) +deriving instance Data (ImportDecl GhcTc) + +-- deriving instance (DataId name) => Data (IE name) +deriving instance Data (IE GhcPs) +deriving instance Data (IE GhcRn) +deriving instance Data (IE GhcTc) + +-- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) +deriving instance Eq (IE GhcPs) +deriving instance Eq (IE GhcRn) +deriving instance Eq (IE GhcTc) + +-- --------------------------------------------------------------------- diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs new file mode 100644 index 0000000000..ab30de87ac --- /dev/null +++ b/compiler/GHC/Hs/Lit.hs @@ -0,0 +1,314 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsLit]{Abstract syntax: source-language literals} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Hs.Lit where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr ) +import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, + negateFractionalLit,SourceText(..),pprWithSourceText ) +import Type +import Outputable +import FastString +import GHC.Hs.Extension + +import Data.ByteString (ByteString) +import Data.Data hiding ( Fixity ) + +{- +************************************************************************ +* * +\subsection[HsLit]{Literals} +* * +************************************************************************ +-} + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +-- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following +-- | Haskell Literal +data HsLit x + = HsChar (XHsChar x) {- SourceText -} Char + -- ^ Character + | HsCharPrim (XHsCharPrim x) {- SourceText -} Char + -- ^ Unboxed character + | HsString (XHsString x) {- SourceText -} FastString + -- ^ String + | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString + -- ^ Packed bytes + | HsInt (XHsInt x) IntegralLit + -- ^ Genuinely an Int; arises from + -- @TcGenDeriv@, and from TRANSLATION + | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer + -- ^ literal @Int#@ + | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer + -- ^ literal @Word#@ + | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer + -- ^ literal @Int64#@ + | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer + -- ^ literal @Word64#@ + | HsInteger (XHsInteger x) {- SourceText -} Integer Type + -- ^ Genuinely an integer; arises only + -- from TRANSLATION (overloaded + -- literals are done with HsOverLit) + | HsRat (XHsRat x) FractionalLit Type + -- ^ Genuinely a rational; arises only from + -- TRANSLATION (overloaded literals are + -- done with HsOverLit) + | HsFloatPrim (XHsFloatPrim x) FractionalLit + -- ^ Unboxed Float + | HsDoublePrim (XHsDoublePrim x) FractionalLit + -- ^ Unboxed Double + + | XLit (XXLit x) + +type instance XHsChar (GhcPass _) = SourceText +type instance XHsCharPrim (GhcPass _) = SourceText +type instance XHsString (GhcPass _) = SourceText +type instance XHsStringPrim (GhcPass _) = SourceText +type instance XHsInt (GhcPass _) = NoExtField +type instance XHsIntPrim (GhcPass _) = SourceText +type instance XHsWordPrim (GhcPass _) = SourceText +type instance XHsInt64Prim (GhcPass _) = SourceText +type instance XHsWord64Prim (GhcPass _) = SourceText +type instance XHsInteger (GhcPass _) = SourceText +type instance XHsRat (GhcPass _) = NoExtField +type instance XHsFloatPrim (GhcPass _) = NoExtField +type instance XHsDoublePrim (GhcPass _) = NoExtField +type instance XXLit (GhcPass _) = NoExtCon + +instance Eq (HsLit x) where + (HsChar _ x1) == (HsChar _ x2) = x1==x2 + (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 + (HsString _ x1) == (HsString _ x2) = x1==x2 + (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 + (HsInt _ x1) == (HsInt _ x2) = x1==x2 + (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 + (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 + (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 + (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 + (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2 + (HsRat _ x1 _) == (HsRat _ x2 _) = x1==x2 + (HsFloatPrim _ x1) == (HsFloatPrim _ x2) = x1==x2 + (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2 + _ == _ = False + +-- | Haskell Overloaded Literal +data HsOverLit p + = OverLit { + ol_ext :: (XOverLit p), + ol_val :: OverLitVal, + ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] + + | XOverLit + (XXOverLit p) + +data OverLitTc + = OverLitTc { + ol_rebindable :: Bool, -- Note [ol_rebindable] + ol_type :: Type } + deriving Data + +type instance XOverLit GhcPs = NoExtField +type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] +type instance XOverLit GhcTc = OverLitTc + +type instance XXOverLit (GhcPass _) = NoExtCon + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +-- | Overloaded Literal Value +data OverLitVal + = HsIntegral !IntegralLit -- ^ Integer-looking literals; + | HsFractional !FractionalLit -- ^ Frac-looking literals + | HsIsString !SourceText !FastString -- ^ String-looking literals + deriving Data + +negateOverLitVal :: OverLitVal -> OverLitVal +negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) +negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) +negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" + +overLitType :: HsOverLit GhcTc -> Type +overLitType (OverLit (OverLitTc _ ty) _ _) = ty +overLitType (XOverLit nec) = noExtCon nec + +-- | Convert a literal from one index type to another, updating the annotations +-- according to the relevant 'Convertable' instance +convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b +convertLit (HsChar a x) = (HsChar (convert a) x) +convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) +convertLit (HsString a x) = (HsString (convert a) x) +convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x) +convertLit (HsInt a x) = (HsInt (convert a) x) +convertLit (HsIntPrim a x) = (HsIntPrim (convert a) x) +convertLit (HsWordPrim a x) = (HsWordPrim (convert a) x) +convertLit (HsInt64Prim a x) = (HsInt64Prim (convert a) x) +convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x) +convertLit (HsInteger a x b) = (HsInteger (convert a) x b) +convertLit (HsRat a x b) = (HsRat (convert a) x b) +convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) +convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) +convertLit (XLit a) = (XLit (convert a)) + +{- +Note [ol_rebindable] +~~~~~~~~~~~~~~~~~~~~ +The ol_rebindable field is True if this literal is actually +using rebindable syntax. Specifically: + + False iff ol_witness is the standard one + True iff ol_witness is non-standard + +Equivalently it's True if + a) RebindableSyntax is on + b) the witness for fromInteger/fromRational/fromString + that happens to be in scope isn't the standard one + +Note [Overloaded literal witnesses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Before* type checking, the HsExpr in an HsOverLit is the +name of the coercion function, 'fromInteger' or 'fromRational'. +*After* type checking, it is a witness for the literal, such as + (fromInteger 3) or lit_78 +This witness should replace the literal. + +This dual role is unusual, because we're replacing 'fromInteger' with +a call to fromInteger. Reason: it allows commoning up of the fromInteger +calls, which wouldn't be possible if the desugarer made the application. + +The PostTcType in each branch records the type the overload literal is +found to have. +-} + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) +instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where + (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 + (XOverLit val1) == (XOverLit val2) = val1 == val2 + _ == _ = panic "Eq HsOverLit" + +instance Eq OverLitVal where + (HsIntegral i1) == (HsIntegral i2) = i1 == i2 + (HsFractional f1) == (HsFractional f2) = f1 == f2 + (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 + _ == _ = False + +instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where + compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2 + compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 + compare _ _ = panic "Ord HsOverLit" + +instance Ord OverLitVal where + compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 + compare (HsIntegral _) (HsFractional _) = LT + compare (HsIntegral _) (HsIsString _ _) = LT + compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 + compare (HsFractional _) (HsIntegral _) = GT + compare (HsFractional _) (HsIsString _ _) = LT + compare (HsIsString _ s1) (HsIsString _ s2) = s1 `compare` s2 + compare (HsIsString _ _) (HsIntegral _) = GT + compare (HsIsString _ _) (HsFractional _) = GT + +-- Instance specific to GhcPs, need the SourceText +instance p ~ GhcPass pass => Outputable (HsLit p) where + ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) + ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) + ppr (HsString st s) = pprWithSourceText st (pprHsString s) + ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) + ppr (HsInt _ i) + = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsInteger st i _) = pprWithSourceText st (integer i) + ppr (HsRat _ f _) = ppr f + ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix + ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix + ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) + ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) + ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) + ppr (XLit x) = ppr x + +pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc +pp_st_suffix NoSourceText _ doc = doc +pp_st_suffix (SourceText st) suffix _ = text st <> suffix + +-- in debug mode, print the expression that it's resolved to, too +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsOverLit p) where + ppr (OverLit {ol_val=val, ol_witness=witness}) + = ppr val <+> (whenPprDebug (parens (pprExpr witness))) + ppr (XOverLit x) = ppr x + +instance Outputable OverLitVal where + ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsFractional f) = ppr f + ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) + +-- | pmPprHsLit pretty prints literals and is used when pretty printing pattern +-- match warnings. All are printed the same (i.e., without hashes if they are +-- primitive and not wrapped in constructors if they are boxed). This happens +-- mainly for too reasons: +-- * We do not want to expose their internal representation +-- * The warnings become too messy +pmPprHsLit :: HsLit (GhcPass x) -> SDoc +pmPprHsLit (HsChar _ c) = pprHsChar c +pmPprHsLit (HsCharPrim _ c) = pprHsChar c +pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) +pmPprHsLit (HsStringPrim _ s) = pprHsBytes s +pmPprHsLit (HsInt _ i) = integer (il_value i) +pmPprHsLit (HsIntPrim _ i) = integer i +pmPprHsLit (HsWordPrim _ w) = integer w +pmPprHsLit (HsInt64Prim _ i) = integer i +pmPprHsLit (HsWord64Prim _ w) = integer w +pmPprHsLit (HsInteger _ i _) = integer i +pmPprHsLit (HsRat _ f _) = ppr f +pmPprHsLit (HsFloatPrim _ f) = ppr f +pmPprHsLit (HsDoublePrim _ d) = ppr d +pmPprHsLit (XLit x) = ppr x + +-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs +-- to be parenthesized under precedence @p@. +hsLitNeedsParens :: PprPrec -> HsLit x -> Bool +hsLitNeedsParens p = go + where + go (HsChar {}) = False + go (HsCharPrim {}) = False + go (HsString {}) = False + go (HsStringPrim {}) = False + go (HsInt _ x) = p > topPrec && il_neg x + go (HsIntPrim _ x) = p > topPrec && x < 0 + go (HsWordPrim {}) = False + go (HsInt64Prim _ x) = p > topPrec && x < 0 + go (HsWord64Prim {}) = False + go (HsInteger _ x _) = p > topPrec && x < 0 + go (HsRat _ x _) = p > topPrec && fl_neg x + go (HsFloatPrim _ x) = p > topPrec && fl_neg x + go (HsDoublePrim _ x) = p > topPrec && fl_neg x + go (XLit _) = False + +-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal +-- @ol@ needs to be parenthesized under precedence @p@. +hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool +hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv + where + go :: OverLitVal -> Bool + go (HsIntegral x) = p > topPrec && il_neg x + go (HsFractional x) = p > topPrec && fl_neg x + go (HsIsString {}) = False +hsOverLitNeedsParens _ (XOverLit { }) = False diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs new file mode 100644 index 0000000000..fe8a4e88d5 --- /dev/null +++ b/compiler/GHC/Hs/Pat.hs @@ -0,0 +1,846 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PatSyntax]{Abstract Haskell syntax---patterns} +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleInstances #-} + +module GHC.Hs.Pat ( + Pat(..), InPat, OutPat, LPat, + ListPatTc(..), + + HsConPatDetails, hsConPatArgs, + HsRecFields(..), HsRecField'(..), LHsRecField', + HsRecField, LHsRecField, + HsRecUpdField, LHsRecUpdField, + hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, + hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, + + mkPrefixConPat, mkCharLitPat, mkNilPat, + + looksLazyPatBind, + isBangedLPat, + patNeedsParens, parenthesizePat, + isIrrefutableHsPat, + + collectEvVarsPat, collectEvVarsPats, + + pprParendLPat, pprConArgs + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Hs.Expr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice) + +-- friends: +import GHC.Hs.Binds +import GHC.Hs.Lit +import GHC.Hs.Extension +import GHC.Hs.Types +import TcEvidence +import BasicTypes +-- others: +import PprCore ( {- instance OutputableBndr TyVar -} ) +import TysWiredIn +import Var +import RdrName ( RdrName ) +import ConLike +import DataCon +import TyCon +import Outputable +import Type +import SrcLoc +import Bag -- collect ev vars from pats +import DynFlags( gopt, GeneralFlag(..) ) +import Maybes +-- libraries: +import Data.Data hiding (TyCon,Fixity) + +type InPat p = LPat p -- No 'Out' constructors +type OutPat p = LPat p -- No 'In' constructors + +type LPat p = Pat p + +-- | Pattern +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' + +-- For details on above see note [Api annotations] in ApiAnnotation +data Pat p + = ------------ Simple patterns --------------- + WildPat (XWildPat p) -- ^ Wildcard Pattern + -- The sole reason for a type on a WildPat is to + -- support hsPatType :: Pat Id -> Type + + -- AZ:TODO above comment needs to be updated + | VarPat (XVarPat p) + (Located (IdP p)) -- ^ Variable Pattern + + -- See Note [Located RdrNames] in GHC.Hs.Expr + | LazyPat (XLazyPat p) + (LPat p) -- ^ Lazy Pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | AsPat (XAsPat p) + (Located (IdP p)) (LPat p) -- ^ As pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | ParPat (XParPat p) + (LPat p) -- ^ Parenthesised pattern + -- See Note [Parens in HsSyn] in GHC.Hs.Expr + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | BangPat (XBangPat p) + (LPat p) -- ^ Bang pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' + + -- For details on above see note [Api annotations] in ApiAnnotation + + ------------ Lists, tuples, arrays --------------- + | ListPat (XListPat p) + [LPat p] + -- For OverloadedLists a Just (ty,fn) gives + -- overall type of the pattern, and the toList +-- function to convert the scrutinee to a list value + + -- ^ Syntactic List + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | TuplePat (XTuplePat p) + -- after typechecking, holds the types of the tuple components + [LPat p] -- Tuple sub-patterns + Boxity -- UnitPat is TuplePat [] + -- You might think that the post typechecking Type was redundant, + -- because we can get the pattern type by getting the types of the + -- sub-patterns. + -- But it's essential + -- data T a where + -- T1 :: Int -> T Int + -- f :: (T a, a) -> Int + -- f (T1 x, z) = z + -- When desugaring, we must generate + -- f = /\a. \v::a. case v of (t::T a, w::a) -> + -- case t of (T1 (x::Int)) -> + -- Note the (w::a), NOT (w::Int), because we have not yet + -- refined 'a' to Int. So we must know that the second component + -- of the tuple is of type 'a' not Int. See selectMatchVar + -- (June 14: I'm not sure this comment is right; the sub-patterns + -- will be wrapped in CoPats, no?) + -- ^ Tuple sub-patterns + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, + -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ + + | SumPat (XSumPat p) -- GHC.Hs.PlaceHolder before typechecker, filled in + -- afterwards with the types of the + -- alternative + (LPat p) -- Sum sub-pattern + ConTag -- Alternative (one-based) + Arity -- Arity (INVARIANT: ≥ 2) + -- ^ Anonymous sum pattern + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'(#'@, + -- 'ApiAnnotation.AnnClose' @'#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + ------------ Constructor patterns --------------- + | ConPatIn (Located (IdP p)) + (HsConPatDetails p) + -- ^ Constructor Pattern In + + | ConPatOut { + pat_con :: Located ConLike, + pat_arg_tys :: [Type], -- The universal arg types, 1-1 with the universal + -- tyvars of the constructor/pattern synonym + -- Use (conLikeResTy pat_con pat_arg_tys) to get + -- the type of the pattern + + pat_tvs :: [TyVar], -- Existentially bound type variables + -- in correctly-scoped order e.g. [k:*, x:k] + pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* + -- One reason for putting coercion variable here, I think, + -- is to ensure their kinds are zonked + + pat_binds :: TcEvBinds, -- Bindings involving those dictionaries + pat_args :: HsConPatDetails p, + pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher + -- Only relevant for pattern-synonyms; + -- ignored for data cons + } + -- ^ Constructor Pattern Out + + ------------ View patterns --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ViewPat (XViewPat p) -- The overall type of the pattern + -- (= the argument type of the view function) + -- for hsPatType. + (LHsExpr p) + (LPat p) + -- ^ View Pattern + + ------------ Pattern splices --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@ + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | SplicePat (XSplicePat p) + (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) + + ------------ Literal and n+k patterns --------------- + | LitPat (XLitPat p) + (HsLit p) -- ^ Literal Pattern + -- Used for *non-overloaded* literal patterns: + -- Int#, Char#, Int, Char, String, etc. + + | NPat -- Natural Pattern + -- Used for all overloaded literals, + -- including overloaded strings with -XOverloadedStrings + (XNPat p) -- Overall type of pattern. Might be + -- different than the literal's type + -- if (==) or negate changes the type + (Located (HsOverLit p)) -- ALWAYS positive + (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for + -- negative patterns, Nothing + -- otherwise + (SyntaxExpr p) -- Equality checker, of type t->t->Bool + + -- ^ Natural Pattern + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | NPlusKPat (XNPlusKPat p) -- Type of overall pattern + (Located (IdP p)) -- n+k pattern + (Located (HsOverLit p)) -- It'll always be an HsIntegral + (HsOverLit p) -- See Note [NPlusK patterns] in TcPat + -- NB: This could be (PostTc ...), but that induced a + -- a new hs-boot file. Not worth it. + + (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool + (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) + -- ^ n+k pattern + + ------------ Pattern type signatures --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SigPat (XSigPat p) -- After typechecker: Type + (LPat p) -- Pattern with a type signature + (LHsSigWcType (NoGhcTc p)) -- Signature can bind both + -- kind and type vars + + -- ^ Pattern with a type signature + + ------------ Pattern coercions (translation only) --------------- + | CoPat (XCoPat p) + HsWrapper -- Coercion Pattern + -- If co :: t1 ~ t2, p :: t2, + -- then (CoPat co p) :: t1 + (Pat p) -- Why not LPat? Ans: existing locn will do + Type -- Type of whole pattern, t1 + -- During desugaring a (CoPat co pat) turns into a cast with 'co' on + -- the scrutinee, followed by a match on 'pat' + -- ^ Coercion Pattern + + -- | Trees that Grow extension point for new constructors + | XPat + (XXPat p) + +-- --------------------------------------------------------------------- + +data ListPatTc + = ListPatTc + Type -- The type of the elements + (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax + +type instance XWildPat GhcPs = NoExtField +type instance XWildPat GhcRn = NoExtField +type instance XWildPat GhcTc = Type + +type instance XVarPat (GhcPass _) = NoExtField +type instance XLazyPat (GhcPass _) = NoExtField +type instance XAsPat (GhcPass _) = NoExtField +type instance XParPat (GhcPass _) = NoExtField +type instance XBangPat (GhcPass _) = NoExtField + +-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap +-- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for +-- `SyntaxExpr` +type instance XListPat GhcPs = NoExtField +type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) +type instance XListPat GhcTc = ListPatTc + +type instance XTuplePat GhcPs = NoExtField +type instance XTuplePat GhcRn = NoExtField +type instance XTuplePat GhcTc = [Type] + +type instance XSumPat GhcPs = NoExtField +type instance XSumPat GhcRn = NoExtField +type instance XSumPat GhcTc = [Type] + +type instance XViewPat GhcPs = NoExtField +type instance XViewPat GhcRn = NoExtField +type instance XViewPat GhcTc = Type + +type instance XSplicePat (GhcPass _) = NoExtField +type instance XLitPat (GhcPass _) = NoExtField + +type instance XNPat GhcPs = NoExtField +type instance XNPat GhcRn = NoExtField +type instance XNPat GhcTc = Type + +type instance XNPlusKPat GhcPs = NoExtField +type instance XNPlusKPat GhcRn = NoExtField +type instance XNPlusKPat GhcTc = Type + +type instance XSigPat GhcPs = NoExtField +type instance XSigPat GhcRn = NoExtField +type instance XSigPat GhcTc = Type + +type instance XCoPat (GhcPass _) = NoExtField +type instance XXPat (GhcPass p) = Located (Pat (GhcPass p)) + + +{- +************************************************************************ +* * +* HasSrcSpan Instance +* * +************************************************************************ +-} + +type instance SrcSpanLess (LPat (GhcPass p)) = Pat (GhcPass p) +instance HasSrcSpan (LPat (GhcPass p)) where + -- NB: The following chooses the behaviour of the outer location + -- wrapper replacing the inner ones. + composeSrcSpan (L sp p) = if sp == noSrcSpan + then p + else XPat (L sp (stripSrcSpanPat p)) + + -- NB: The following only returns the top-level location, if any. + decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) + decomposeSrcSpan p = L noSrcSpan p + +stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p) +stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p +stripSrcSpanPat p = p + + + +-- --------------------------------------------------------------------- + + +-- | Haskell Constructor Pattern Details +type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) + +hsConPatArgs :: HsConPatDetails p -> [LPat p] +hsConPatArgs (PrefixCon ps) = ps +hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) +hsConPatArgs (InfixCon p1 p2) = [p1,p2] + +-- | Haskell Record Fields +-- +-- HsRecFields is used only for patterns and expressions (not data type +-- declarations) +data HsRecFields p arg -- A bunch of record fields + -- { x = 3, y = True } + -- Used for both expressions and patterns + = HsRecFields { rec_flds :: [LHsRecField p arg], + rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] + deriving (Functor, Foldable, Traversable) + + +-- Note [DotDot fields] +-- ~~~~~~~~~~~~~~~~~~~~ +-- The rec_dotdot field means this: +-- Nothing => the normal case +-- Just n => the group uses ".." notation, +-- +-- In the latter case: +-- +-- *before* renamer: rec_flds are exactly the n user-written fields +-- +-- *after* renamer: rec_flds includes *all* fields, with +-- the first 'n' being the user-written ones +-- and the remainder being 'filled in' implicitly + +-- | Located Haskell Record Field +type LHsRecField' p arg = Located (HsRecField' p arg) + +-- | Located Haskell Record Field +type LHsRecField p arg = Located (HsRecField p arg) + +-- | Located Haskell Record Update Field +type LHsRecUpdField p = Located (HsRecUpdField p) + +-- | Haskell Record Field +type HsRecField p arg = HsRecField' (FieldOcc p) arg + +-- | Haskell Record Update Field +type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p) + +-- | Haskell Record Field +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', +-- +-- For details on above see note [Api annotations] in ApiAnnotation +data HsRecField' id arg = HsRecField { + hsRecFieldLbl :: Located id, + hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning + hsRecPun :: Bool -- ^ Note [Punning] + } deriving (Data, Functor, Foldable, Traversable) + + +-- Note [Punning] +-- ~~~~~~~~~~~~~~ +-- If you write T { x, y = v+1 }, the HsRecFields will be +-- HsRecField x x True ... +-- HsRecField y (v+1) False ... +-- That is, for "punned" field x is expanded (in the renamer) +-- to x=x; but with a punning flag so we can detect it later +-- (e.g. when pretty printing) +-- +-- If the original field was qualified, we un-qualify it, thus +-- T { A.x } means T { A.x = x } + + +-- Note [HsRecField and HsRecUpdField] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- A HsRecField (used for record construction and pattern matching) +-- contains an unambiguous occurrence of a field (i.e. a FieldOcc). +-- We can't just store the Name, because thanks to +-- DuplicateRecordFields this may not correspond to the label the user +-- wrote. +-- +-- A HsRecUpdField (used for record update) contains a potentially +-- ambiguous occurrence of a field (an AmbiguousFieldOcc). The +-- renamer will fill in the selector function if it can, but if the +-- selector is ambiguous the renamer will defer to the typechecker. +-- After the typechecker, a unique selector will have been determined. +-- +-- The renamer produces an Unambiguous result if it can, rather than +-- just doing the lookup in the typechecker, so that completely +-- unambiguous updates can be represented by 'DsMeta.repUpdFields'. +-- +-- For example, suppose we have: +-- +-- data S = MkS { x :: Int } +-- data T = MkT { x :: Int } +-- +-- f z = (z { x = 3 }) :: S +-- +-- The parsed HsRecUpdField corresponding to the record update will have: +-- +-- hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName +-- +-- After the renamer, this will become: +-- +-- hsRecFieldLbl = Ambiguous "x" noExtField :: AmbiguousFieldOcc Name +-- +-- (note that the Unambiguous constructor is not type-correct here). +-- The typechecker will determine the particular selector: +-- +-- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id +-- +-- See also Note [Disambiguating record fields] in TcExpr. + +hsRecFields :: HsRecFields p arg -> [XCFieldOcc p] +hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) + +-- Probably won't typecheck at once, things have changed :/ +hsRecFieldsArgs :: HsRecFields p arg -> [arg] +hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) + +hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass) +hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl + +hsRecFieldId :: HsRecField GhcTc arg -> Located Id +hsRecFieldId = hsRecFieldSel + +hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName +hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl + +hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id +hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc + +hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc +hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl + + +{- +************************************************************************ +* * +* Printing patterns +* * +************************************************************************ +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where + ppr = pprPat + +pprPatBndr :: OutputableBndr name => name -> SDoc +pprPatBndr var -- Print with type info if -dppr-debug is on + = getPprStyle $ \ sty -> + if debugStyle sty then + parens (pprBndr LambdaBind var) -- Could pass the site to pprPat + -- but is it worth it? + else + pprPrefixOcc var + +pprParendLPat :: (OutputableBndrId (GhcPass p)) + => PprPrec -> LPat (GhcPass p) -> SDoc +pprParendLPat p = pprParendPat p . unLoc + +pprParendPat :: (OutputableBndrId (GhcPass p)) + => PprPrec -> Pat (GhcPass p) -> SDoc +pprParendPat p pat = sdocWithDynFlags $ \ dflags -> + if need_parens dflags pat + then parens (pprPat pat) + else pprPat pat + where + need_parens dflags pat + | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags + | otherwise = patNeedsParens p pat + -- For a CoPat we need parens if we are going to show it, which + -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) + -- But otherwise the CoPat is discarded, so it + -- is the pattern inside that matters. Sigh. + +pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc +pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) +pprPat (WildPat _) = char '_' +pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat +pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat +pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', + pprParendLPat appPrec pat] +pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] +pprPat (ParPat _ pat) = parens (ppr pat) +pprPat (LitPat _ s) = ppr s +pprPat (NPat _ l Nothing _) = ppr l +pprPat (NPat _ l (Just _) _) = char '-' <> ppr l +pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k] +pprPat (SplicePat _ splice) = pprSplice splice +pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens + -> if parens + then pprParendPat appPrec pat + else pprPat pat +pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (ListPat _ pats) = brackets (interpp'SP pats) +pprPat (TuplePat _ pats bx) = tupleParens (boxityTupleSort bx) + (pprWithCommas ppr pats) +pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) +pprPat (ConPatIn con details) = pprUserCon (unLoc con) details +pprPat (ConPatOut { pat_con = con + , pat_tvs = tvs + , pat_dicts = dicts + , pat_binds = binds + , pat_args = details }) + = sdocWithDynFlags $ \dflags -> + -- Tiresome; in TcBinds.tcRhs we print out a + -- typechecked Pat in an error message, + -- and we want to make sure it prints nicely + if gopt Opt_PrintTypecheckerElaboration dflags then + ppr con + <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) + , ppr binds]) + <+> pprConArgs details + else pprUserCon (unLoc con) details +pprPat (XPat x) = ppr x + + +pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p)) + => con -> HsConPatDetails (GhcPass p) -> SDoc +pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 +pprUserCon c details = pprPrefixOcc c <+> pprConArgs details + +pprConArgs :: (OutputableBndrId (GhcPass p)) + => HsConPatDetails (GhcPass p) -> SDoc +pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats) +pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 + , pprParendLPat appPrec p2 ] +pprConArgs (RecCon rpats) = ppr rpats + +instance (Outputable arg) + => Outputable (HsRecFields p arg) where + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) + = braces (fsep (punctuate comma (map ppr flds))) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) + = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) + where + dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) + +instance (Outputable p, Outputable arg) + => Outputable (HsRecField' p arg) where + ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, + hsRecPun = pun }) + = ppr f <+> (ppUnless pun $ equals <+> ppr arg) + + +{- +************************************************************************ +* * +* Building patterns +* * +************************************************************************ +-} + +mkPrefixConPat :: DataCon -> + [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p) +-- Make a vanilla Prefix constructor pattern +mkPrefixConPat dc pats tys + = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc) + , pat_tvs = [] + , pat_dicts = [] + , pat_binds = emptyTcEvBinds + , pat_args = PrefixCon pats + , pat_arg_tys = tys + , pat_wrap = idHsWrapper } + +mkNilPat :: Type -> OutPat (GhcPass p) +mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] + +mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) +mkCharLitPat src c = mkPrefixConPat charDataCon + [noLoc $ LitPat noExtField (HsCharPrim src c)] [] + +{- +************************************************************************ +* * +* Predicates for checking things about pattern-lists in EquationInfo * +* * +************************************************************************ + +\subsection[Pat-list-predicates]{Look for interesting things in patterns} + +Unlike in the Wadler chapter, where patterns are either ``variables'' +or ``constructors,'' here we distinguish between: +\begin{description} +\item[unfailable:] +Patterns that cannot fail to match: variables, wildcards, and lazy +patterns. + +These are the irrefutable patterns; the two other categories +are refutable patterns. + +\item[constructor:] +A non-literal constructor pattern (see next category). + +\item[literal patterns:] +At least the numeric ones may be overloaded. +\end{description} + +A pattern is in {\em exactly one} of the above three categories; `as' +patterns are treated specially, of course. + +The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. +-} + +isBangedLPat :: LPat (GhcPass p) -> Bool +isBangedLPat = isBangedPat . unLoc + +isBangedPat :: Pat (GhcPass p) -> Bool +isBangedPat (ParPat _ p) = isBangedLPat p +isBangedPat (BangPat {}) = True +isBangedPat _ = False + +looksLazyPatBind :: HsBind (GhcPass p) -> Bool +-- Returns True of anything *except* +-- a StrictHsBind (as above) or +-- a VarPat +-- In particular, returns True of a pattern binding with a compound pattern, like (I# x) +-- Looks through AbsBinds +looksLazyPatBind (PatBind { pat_lhs = p }) + = looksLazyLPat p +looksLazyPatBind (AbsBinds { abs_binds = binds }) + = anyBag (looksLazyPatBind . unLoc) binds +looksLazyPatBind _ + = False + +looksLazyLPat :: LPat (GhcPass p) -> Bool +looksLazyLPat = looksLazyPat . unLoc + +looksLazyPat :: Pat (GhcPass p) -> Bool +looksLazyPat (ParPat _ p) = looksLazyLPat p +looksLazyPat (AsPat _ _ p) = looksLazyLPat p +looksLazyPat (BangPat {}) = False +looksLazyPat (VarPat {}) = False +looksLazyPat (WildPat {}) = False +looksLazyPat _ = True + +isIrrefutableHsPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> Bool +-- (isIrrefutableHsPat p) is true if matching against p cannot fail, +-- in the sense of falling through to the next pattern. +-- (NB: this is not quite the same as the (silly) defn +-- in 3.17.2 of the Haskell 98 report.) +-- +-- WARNING: isIrrefutableHsPat returns False if it's in doubt. +-- Specifically on a ConPatIn, which is what it sees for a +-- (LPat Name) in the renamer, it doesn't know the size of the +-- constructor family, so it returns False. Result: only +-- tuple patterns are considered irrefuable at the renamer stage. +-- +-- But if it returns True, the pattern is definitely irrefutable +isIrrefutableHsPat + = goL + where + goL = go . unLoc + + go (WildPat {}) = True + go (VarPat {}) = True + go (LazyPat {}) = True + go (BangPat _ pat) = goL pat + go (CoPat _ _ pat _) = go pat + go (ParPat _ pat) = goL pat + go (AsPat _ _ pat) = goL pat + go (ViewPat _ _ pat) = goL pat + go (SigPat _ pat _) = goL pat + go (TuplePat _ pats _) = all goL pats + go (SumPat {}) = False + -- See Note [Unboxed sum patterns aren't irrefutable] + go (ListPat {}) = False + + go (ConPatIn {}) = False -- Conservative + go (ConPatOut + { pat_con = (dL->L _ (RealDataCon con)) + , pat_args = details }) + = + isJust (tyConSingleDataCon_maybe (dataConTyCon con)) + -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because + -- the latter is false of existentials. See #4439 + && all goL (hsConPatArgs details) + go (ConPatOut + { pat_con = (dL->L _ (PatSynCon _pat)) }) + = False -- Conservative + go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884 + go (LitPat {}) = False + go (NPat {}) = False + go (NPlusKPat {}) = False + + -- We conservatively assume that no TH splices are irrefutable + -- since we cannot know until the splice is evaluated. + go (SplicePat {}) = False + + go (XPat {}) = False + +{- Note [Unboxed sum patterns aren't irrefutable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as +patterns. A simple example that demonstrates this is from #14228: + + pattern Just' x = (# x | #) + pattern Nothing' = (# | () #) + + foo x = case x of + Nothing' -> putStrLn "nothing" + Just' -> putStrLn "just" + +In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable, +as does not match an unboxed sum value of the same arity—namely, (# | y #) +(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the +minimum unboxed sum arity is 2. + +Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' +case in foo to be unreachable, as GHC would mistakenly believe that Nothing' +is the only thing that could possibly be matched! +-} + +-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs +-- parentheses under precedence @p@. +patNeedsParens :: PprPrec -> Pat p -> Bool +patNeedsParens p = go + where + go (NPlusKPat {}) = p > opPrec + go (SplicePat {}) = False + go (ConPatIn _ ds) = conPatNeedsParens p ds + go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp) + go (SigPat {}) = p >= sigPrec + go (ViewPat {}) = True + go (CoPat _ _ p _) = go p + go (WildPat {}) = False + go (VarPat {}) = False + go (LazyPat {}) = False + go (BangPat {}) = False + go (ParPat {}) = False + go (AsPat {}) = False + go (TuplePat {}) = False + go (SumPat {}) = False + go (ListPat {}) = False + go (LitPat _ l) = hsLitNeedsParens p l + go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol) + go (XPat {}) = True -- conservative default + +-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ +-- needs parentheses under precedence @p@. +conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool +conPatNeedsParens p = go + where + go (PrefixCon args) = p >= appPrec && not (null args) + go (InfixCon {}) = p >= opPrec + go (RecCon {}) = False + +-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and +-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. +parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) +parenthesizePat p lpat@(dL->L loc pat) + | patNeedsParens p pat = cL loc (ParPat noExtField lpat) + | otherwise = lpat + +{- +% Collect all EvVars from all constructor patterns +-} + +-- May need to add more cases +collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar +collectEvVarsPats = unionManyBags . map collectEvVarsPat + +collectEvVarsLPat :: LPat GhcTc -> Bag EvVar +collectEvVarsLPat = collectEvVarsPat . unLoc + +collectEvVarsPat :: Pat GhcTc -> Bag EvVar +collectEvVarsPat pat = + case pat of + LazyPat _ p -> collectEvVarsLPat p + AsPat _ _ p -> collectEvVarsLPat p + ParPat _ p -> collectEvVarsLPat p + BangPat _ p -> collectEvVarsLPat p + ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps + TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps + SumPat _ p _ _ -> collectEvVarsLPat p + ConPatOut {pat_dicts = dicts, pat_args = args} + -> unionBags (listToBag dicts) + $ unionManyBags + $ map collectEvVarsLPat + $ hsConPatArgs args + SigPat _ p _ -> collectEvVarsLPat p + CoPat _ _ p _ -> collectEvVarsPat p + ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" + _other_pat -> emptyBag diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot new file mode 100644 index 0000000000..801f481879 --- /dev/null +++ b/compiler/GHC/Hs/Pat.hs-boot @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP, KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Hs.Pat where + +import Outputable +import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) + +type role Pat nominal +data Pat (i :: *) +type LPat i = Pat i + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) diff --git a/compiler/GHC/Hs/PlaceHolder.hs b/compiler/GHC/Hs/PlaceHolder.hs new file mode 100644 index 0000000000..faaa1331ab --- /dev/null +++ b/compiler/GHC/Hs/PlaceHolder.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Hs.PlaceHolder where + +import Name +import NameSet +import RdrName +import Var + + + +{- +%************************************************************************ +%* * +\subsection{Annotating the syntax} +%* * +%************************************************************************ +-} + +-- NB: These are intentionally open, allowing API consumers (like Haddock) +-- to declare new instances + +placeHolderNamesTc :: NameSet +placeHolderNamesTc = emptyNameSet + +{- +TODO:AZ: remove this, and check if we still need all the UndecidableInstances + +Note [Pass sensitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the same AST types are re-used through parsing,renaming and type +checking there are naturally some places in the AST that do not have +any meaningful value prior to the pass they are assigned a value. + +Historically these have been filled in with place holder values of the form + + panic "error message" + +This has meant the AST is difficult to traverse using standard generic +programming techniques. The problem is addressed by introducing +pass-specific data types, implemented as a pair of open type families, +one for PostTc and one for PostRn. These are then explicitly populated +with a PlaceHolder value when they do not yet have meaning. + +In terms of actual usage, we have the following + + PostTc id Kind + PostTc id Type + + PostRn id Fixity + PostRn id NameSet + +TcId and Var are synonyms for Id + +Unfortunately the type checker termination checking conditions fail for the +DataId constraint type based on this, so even though it is safe the +UndecidableInstances pragma is required where this is used. +-} + + +-- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', +-- for printing messages related to a 'Match' +type family NameOrRdrName id where + NameOrRdrName Id = Name + NameOrRdrName Name = Name + NameOrRdrName RdrName = RdrName diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs new file mode 100644 index 0000000000..f14d59ba4a --- /dev/null +++ b/compiler/GHC/Hs/Types.hs @@ -0,0 +1,1724 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +GHC.Hs.Types: Abstract syntax: user-defined types +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Hs.Types ( + HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, + HsTyVarBndr(..), LHsTyVarBndr, ForallVisFlag(..), + LHsQTyVars(..), + HsImplicitBndrs(..), + HsWildCardBndrs(..), + LHsSigType, LHsSigWcType, LHsWcType, + HsTupleSort(..), + HsContext, LHsContext, noLHsContext, + HsTyLit(..), + HsIPName(..), hsIPNameFS, + HsArg(..), numVisibleArgs, + LHsTypeArg, + + LBangType, BangType, + HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..), + getBangType, getBangStrictness, + + ConDeclField(..), LConDeclField, pprConDeclFields, + + HsConDetails(..), + + FieldOcc(..), LFieldOcc, mkFieldOcc, + AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, + rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, + unambiguousFieldOcc, ambiguousFieldOcc, + + mkAnonWildCardTy, pprAnonWildCard, + + mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, + mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, + mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, + isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, + hsScopedTvs, hsWcScopedTvs, dropWildCards, + hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, + splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, + splitLHsPatSynTy, + splitLHsForAllTy, splitLHsForAllTyInvis, + splitLHsQualTy, splitLHsSigmaTy, splitLHsSigmaTyInvis, + splitHsFunType, hsTyGetAppHead_maybe, + mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, + ignoreParens, hsSigType, hsSigWcType, + hsLTyVarBndrToType, hsLTyVarBndrsToTypes, + hsConDetailsArgs, + + -- Printing + pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll, + pprLHsContext, + hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice ) + +import GHC.Hs.Extension + +import Id ( Id ) +import Name( Name ) +import RdrName ( RdrName ) +import DataCon( HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..) ) +import TysPrim( funTyConName ) +import Type +import GHC.Hs.Doc +import BasicTypes +import SrcLoc +import Outputable +import FastString +import Maybes( isJust ) +import Util ( count, debugIsOn ) + +import Data.Data hiding ( Fixity, Prefix, Infix ) + +{- +************************************************************************ +* * +\subsection{Bang annotations} +* * +************************************************************************ +-} + +-- | Located Bang Type +type LBangType pass = Located (BangType pass) + +-- | Bang Type +-- +-- In the parser, strictness and packedness annotations bind more tightly +-- than docstrings. This means that when consuming a 'BangType' (and looking +-- for 'HsBangTy') we must be ready to peer behind a potential layer of +-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example. +type BangType pass = HsType pass -- Bangs are in the HsType data type + +getBangType :: LHsType a -> LHsType a +getBangType (L _ (HsBangTy _ _ lty)) = lty +getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) = + addCLoc lty lds (HsDocTy x lty lds) +getBangType lty = lty + +getBangStrictness :: LHsType a -> HsSrcBang +getBangStrictness (L _ (HsBangTy _ s _)) = s +getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s +getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) + +{- +************************************************************************ +* * +\subsection{Data types} +* * +************************************************************************ + +This is the syntax for types as seen in type signatures. + +Note [HsBSig binder lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a binder (or pattern) decorated with a type or kind, + \ (x :: a -> a). blah + forall (a :: k -> *) (b :: k). blah +Then we use a LHsBndrSig on the binder, so that the +renamer can decorate it with the variables bound +by the pattern ('a' in the first example, 'k' in the second), +assuming that neither of them is in scope already +See also Note [Kind and type-variable binders] in RnTypes + +Note [HsType binders] +~~~~~~~~~~~~~~~~~~~~~ +The system for recording type and kind-variable binders in HsTypes +is a bit complicated. Here's how it works. + +* In a HsType, + HsForAllTy represents an /explicit, user-written/ 'forall' + e.g. forall a b. {...} or + forall a b -> {...} + HsQualTy represents an /explicit, user-written/ context + e.g. (Eq a, Show a) => ... + The context can be empty if that's what the user wrote + These constructors represent what the user wrote, no more + and no less. + +* The ForallVisFlag field of HsForAllTy represents whether a forall is + invisible (e.g., forall a b. {...}, with a dot) or visible + (e.g., forall a b -> {...}, with an arrow). + +* HsTyVarBndr describes a quantified type variable written by the + user. For example + f :: forall a (b :: *). blah + here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has + a list of LHsTyVarBndrs. + +* HsImplicitBndrs is a wrapper that gives the implicitly-quantified + kind and type variables of the wrapped thing. It is filled in by + the renamer. For example, if the user writes + f :: a -> a + the HsImplicitBinders binds the 'a' (not a HsForAllTy!). + NB: this implicit quantification is purely lexical: we bind any + type or kind variables that are not in scope. The type checker + may subsequently quantify over further kind variables. + +* HsWildCardBndrs is a wrapper that binds the wildcard variables + of the wrapped thing. It is filled in by the renamer + f :: _a -> _ + The enclosing HsWildCardBndrs binds the wildcards _a and _. + +* The explicit presence of these wrappers specifies, in the HsSyn, + exactly where implicit quantification is allowed, and where + wildcards are allowed. + +* LHsQTyVars is used in data/class declarations, where the user gives + explicit *type* variable bindings, but we need to implicitly bind + *kind* variables. For example + class C (a :: k -> *) where ... + The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars + +Note [The wildcard story for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types can have wildcards in them, to support partial type signatures, +like f :: Int -> (_ , _a) -> _a + +A wildcard in a type can be + + * An anonymous wildcard, + written '_' + In HsType this is represented by HsWildCardTy. + The renamer leaves it untouched, and it is later given fresh meta tyvars in + the typechecker. + + * A named wildcard, + written '_a', '_foo', etc + In HsType this is represented by (HsTyVar "_a") + i.e. a perfectly ordinary type variable that happens + to start with an underscore + +Note carefully: + +* When NamedWildCards is off, type variables that start with an + underscore really /are/ ordinary type variables. And indeed, even + when NamedWildCards is on you can bind _a explicitly as an ordinary + type variable: + data T _a _b = MkT _b _a + Or even: + f :: forall _a. _a -> _b + Here _a is an ordinary forall'd binder, but (With NamedWildCards) + _b is a named wildcard. (See the comments in #10982) + +* Named wildcards are bound by the HsWildCardBndrs construct, which wraps + types that are allowed to have wildcards. Unnamed wildcards however are left + unchanged until typechecking, where we give them fresh wild tyavrs and + determine whether or not to emit hole constraints on each wildcard + (we don't if it's a visible type/kind argument or a type family pattern). + See related notes Note [Wildcards in visible kind application] + and Note [Wildcards in visible type application] in TcHsType.hs + +* After type checking is done, we report what types the wildcards + got unified with. + +Note [Ordering of implicit variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the advent of -XTypeApplications, GHC makes promises about the ordering +of implicit variable quantification. Specifically, we offer that implicitly +quantified variables (such as those in const :: a -> b -> a, without a `forall`) +will occur in left-to-right order of first occurrence. Here are a few examples: + + const :: a -> b -> a -- forall a b. ... + f :: Eq a => b -> a -> a -- forall a b. ... contexts are included + + type a <-< b = b -> a + g :: a <-< b -- forall a b. ... type synonyms matter + + class Functor f where + fmap :: (a -> b) -> f a -> f b -- forall f a b. ... + -- The f is quantified by the class, so only a and b are considered in fmap + +This simple story is complicated by the possibility of dependency: all variables +must come after any variables mentioned in their kinds. + + typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... + +The k comes first because a depends on k, even though the k appears later than +the a in the code. Thus, GHC does a *stable topological sort* on the variables. +By "stable", we mean that any two variables who do not depend on each other +preserve their existing left-to-right ordering. + +Implicitly bound variables are collected by the extract- family of functions +(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes. +These functions thus promise to keep left-to-right ordering. +Look for pointers to this note to see the places where the action happens. + +Note that we also maintain this ordering in kind signatures. Even though +there's no visible kind application (yet), having implicit variables be +quantified in left-to-right order in kind signatures is nice since: + +* It's consistent with the treatment for type signatures. +* It can affect how types are displayed with -fprint-explicit-kinds (see + #15568 for an example), which is a situation where knowing the order in + which implicit variables are quantified can be useful. +* In the event that visible kind application is implemented, the order in + which we would expect implicit variables to be ordered in kinds will have + already been established. +-} + +-- | Located Haskell Context +type LHsContext pass = Located (HsContext pass) + -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' + -- For details on above see note [Api annotations] in ApiAnnotation + +noLHsContext :: LHsContext pass +-- Use this when there is no context in the original program +-- It would really be more kosher to use a Maybe, to distinguish +-- class () => C a where ... +-- from +-- class C a where ... +noLHsContext = noLoc [] + +-- | Haskell Context +type HsContext pass = [LHsType pass] + +-- | Located Haskell Type +type LHsType pass = Located (HsType pass) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | Haskell Kind +type HsKind pass = HsType pass + +-- | Located Haskell Kind +type LHsKind pass = Located (HsKind pass) + -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + +-------------------------------------------------- +-- LHsQTyVars +-- The explicitly-quantified binders in a data/type declaration + +-- | Located Haskell Type Variable Binder +type LHsTyVarBndr pass = Located (HsTyVarBndr pass) + -- See Note [HsType binders] + +-- | Located Haskell Quantified Type Variables +data LHsQTyVars pass -- See Note [HsType binders] + = HsQTvs { hsq_ext :: XHsQTvs pass + + , hsq_explicit :: [LHsTyVarBndr pass] + -- Explicit variables, written by the user + -- See Note [HsForAllTy tyvar binders] + } + | XLHsQTyVars (XXLHsQTyVars pass) + +type HsQTvsRn = [Name] -- Implicit variables + -- For example, in data T (a :: k1 -> k2) = ... + -- the 'a' is explicit while 'k1', 'k2' are implicit + +type instance XHsQTvs GhcPs = NoExtField +type instance XHsQTvs GhcRn = HsQTvsRn +type instance XHsQTvs GhcTc = HsQTvsRn + +type instance XXLHsQTyVars (GhcPass _) = NoExtCon + +mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs +mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } + +hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] +hsQTvExplicit = hsq_explicit + +emptyLHsQTvs :: LHsQTyVars GhcRn +emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] } + +isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool +isEmptyLHsQTvs (HsQTvs { hsq_ext = imp, hsq_explicit = exp }) + = null imp && null exp +isEmptyLHsQTvs _ = False + +------------------------------------------------ +-- HsImplicitBndrs +-- Used to quantify the implicit binders of a type +-- * Implicit binders of a type signature (LHsSigType/LHsSigWcType) +-- * Patterns in a type/data family instance (HsTyPats) + +-- | Haskell Implicit Binders +data HsImplicitBndrs pass thing -- See Note [HsType binders] + = HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name] + -- Implicitly-bound kind & type vars + -- Order is important; see + -- Note [Ordering of implicit variables] + -- in RnTypes + + , hsib_body :: thing -- Main payload (type or list of types) + } + | XHsImplicitBndrs (XXHsImplicitBndrs pass thing) + +type instance XHsIB GhcPs _ = NoExtField +type instance XHsIB GhcRn _ = [Name] +type instance XHsIB GhcTc _ = [Name] + +type instance XXHsImplicitBndrs (GhcPass _) _ = NoExtCon + +-- | Haskell Wildcard Binders +data HsWildCardBndrs pass thing + -- See Note [HsType binders] + -- See Note [The wildcard story for types] + = HsWC { hswc_ext :: XHsWC pass thing + -- after the renamer + -- Wild cards, only named + -- See Note [Wildcards in visible kind application] + + , hswc_body :: thing + -- Main payload (type or list of types) + -- If there is an extra-constraints wildcard, + -- it's still there in the hsc_body. + } + | XHsWildCardBndrs (XXHsWildCardBndrs pass thing) + +type instance XHsWC GhcPs b = NoExtField +type instance XHsWC GhcRn b = [Name] +type instance XHsWC GhcTc b = [Name] + +type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon + +-- | Located Haskell Signature Type +type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only + +-- | Located Haskell Wildcard Type +type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only + +-- | Located Haskell Signature Wildcard Type +type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both + +-- See Note [Representing type signatures] + +hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing +hsImplicitBody (HsIB { hsib_body = body }) = body +hsImplicitBody (XHsImplicitBndrs nec) = noExtCon nec + +hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) +hsSigType = hsImplicitBody + +hsSigWcType :: LHsSigWcType pass -> LHsType pass +hsSigWcType sig_ty = hsib_body (hswc_body sig_ty) + +dropWildCards :: LHsSigWcType pass -> LHsSigType pass +-- Drop the wildcard part of a LHsSigWcType +dropWildCards sig_ty = hswc_body sig_ty + +{- Note [Representing type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsSigType is used to represent an explicit user type signature +such as f :: a -> a + or g (x :: a -> a) = x + +A HsSigType is just a HsImplicitBndrs wrapping a LHsType. + * The HsImplicitBndrs binds the /implicitly/ quantified tyvars + * The LHsType binds the /explicitly/ quantified tyvars + +E.g. For a signature like + f :: forall (a::k). blah +we get + HsIB { hsib_vars = [k] + , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] + , hst_body = blah } +The implicit kind variable 'k' is bound by the HsIB; +the explicitly forall'd tyvar 'a' is bound by the HsForAllTy +-} + +mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing +mkHsImplicitBndrs x = HsIB { hsib_ext = noExtField + , hsib_body = x } + +mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing +mkHsWildCardBndrs x = HsWC { hswc_body = x + , hswc_ext = noExtField } + +-- Add empty binders. This is a bit suspicious; what if +-- the wrapped thing had free type variables? +mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing +mkEmptyImplicitBndrs x = HsIB { hsib_ext = [] + , hsib_body = x } + +mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing +mkEmptyWildCardBndrs x = HsWC { hswc_body = x + , hswc_ext = [] } + + +-------------------------------------------------- +-- | These names are used early on to store the names of implicit +-- parameters. They completely disappear after type-checking. +newtype HsIPName = HsIPName FastString + deriving( Eq, Data ) + +hsIPNameFS :: HsIPName -> FastString +hsIPNameFS (HsIPName n) = n + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n + +-------------------------------------------------- + +-- | Haskell Type Variable Binder +data HsTyVarBndr pass + = UserTyVar -- no explicit kinding + (XUserTyVar pass) + (Located (IdP pass)) + -- See Note [Located RdrNames] in GHC.Hs.Expr + | KindedTyVar + (XKindedTyVar pass) + (Located (IdP pass)) + (LHsKind pass) -- The user-supplied kind signature + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | XTyVarBndr + (XXTyVarBndr pass) + +type instance XUserTyVar (GhcPass _) = NoExtField +type instance XKindedTyVar (GhcPass _) = NoExtField +type instance XXTyVarBndr (GhcPass _) = NoExtCon + +-- | Does this 'HsTyVarBndr' come with an explicit kind annotation? +isHsKindedTyVar :: HsTyVarBndr pass -> Bool +isHsKindedTyVar (UserTyVar {}) = False +isHsKindedTyVar (KindedTyVar {}) = True +isHsKindedTyVar (XTyVarBndr {}) = False + +-- | Do all type variables in this 'LHsQTyVars' come with kind annotations? +hsTvbAllKinded :: LHsQTyVars pass -> Bool +hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit + +-- | Haskell Type +data HsType pass + = HsForAllTy -- See Note [HsType binders] + { hst_xforall :: XForAllTy pass + , hst_fvf :: ForallVisFlag -- Is this `forall a -> {...}` or + -- `forall a. {...}`? + , hst_bndrs :: [LHsTyVarBndr pass] + -- Explicit, user-supplied 'forall a b c' + , hst_body :: LHsType pass -- body type + } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', + -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsQualTy -- See Note [HsType binders] + { hst_xqual :: XQualTy pass + , hst_ctxt :: LHsContext pass -- Context C => blah + , hst_body :: LHsType pass } + + | HsTyVar (XTyVar pass) + PromotionFlag -- Whether explicitly promoted, + -- for the pretty printer + (Located (IdP pass)) + -- Type variable, type constructor, or data constructor + -- see Note [Promotions (HsTyVar)] + -- See Note [Located RdrNames] in GHC.Hs.Expr + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsAppTy (XAppTy pass) + (LHsType pass) + (LHsType pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsAppKindTy (XAppKindTy pass) -- type level type app + (LHsType pass) + (LHsKind pass) + + | HsFunTy (XFunTy pass) + (LHsType pass) -- function type + (LHsType pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsListTy (XListTy pass) + (LHsType pass) -- Element type + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsTupleTy (XTupleTy pass) + HsTupleSort + [LHsType pass] -- Element types (length gives arity) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, + -- 'ApiAnnotation.AnnClose' @')' or '#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsSumTy (XSumTy pass) + [LHsType pass] -- Element types (length gives arity) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, + -- 'ApiAnnotation.AnnClose' '#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsOpTy (XOpTy pass) + (LHsType pass) (Located (IdP pass)) (LHsType pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsParTy (XParTy pass) + (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr + -- Parenthesis preserved for the precedence re-arrangement in RnTypes + -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsIParamTy (XIParamTy pass) + (Located HsIPName) -- (?x :: ty) + (LHsType pass) -- Implicit parameters as they occur in + -- contexts + -- ^ + -- > (?x :: ty) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsStarTy (XStarTy pass) + Bool -- Is this the Unicode variant? + -- Note [HsStarTy] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + | HsKindSig (XKindSig pass) + (LHsType pass) -- (ty :: kind) + (LHsKind pass) -- A type with a kind signature + -- ^ + -- > (ty :: kind) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsSpliceTy (XSpliceTy pass) + (HsSplice pass) -- Includes quasi-quotes + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsDocTy (XDocTy pass) + (LHsType pass) LHsDocString -- A documented type + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsBangTy (XBangTy pass) + HsSrcBang (LHsType pass) -- Bang-style type annotations + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, + -- 'ApiAnnotation.AnnClose' @'#-}'@ + -- 'ApiAnnotation.AnnBang' @\'!\'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsRecTy (XRecTy pass) + [LConDeclField pass] -- Only in data type declarations + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* + -- -- Core Type through HsSyn. + -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsExplicitListTy -- A promoted explicit list + (XExplicitListTy pass) + PromotionFlag -- whether explcitly promoted, for pretty printer + [LHsType pass] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsExplicitTupleTy -- A promoted explicit tuple + (XExplicitTupleTy pass) + [LHsType pass] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsWildCardTy (XWildCardTy pass) -- A type wildcard + -- See Note [The wildcard story for types] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + -- For adding new constructors via Trees that Grow + | XHsType + (XXType pass) + +data NewHsTypeX + = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* + -- Core Type through HsSyn. + deriving Data + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + +instance Outputable NewHsTypeX where + ppr (NHsCoreTy ty) = ppr ty + +type instance XForAllTy (GhcPass _) = NoExtField +type instance XQualTy (GhcPass _) = NoExtField +type instance XTyVar (GhcPass _) = NoExtField +type instance XAppTy (GhcPass _) = NoExtField +type instance XFunTy (GhcPass _) = NoExtField +type instance XListTy (GhcPass _) = NoExtField +type instance XTupleTy (GhcPass _) = NoExtField +type instance XSumTy (GhcPass _) = NoExtField +type instance XOpTy (GhcPass _) = NoExtField +type instance XParTy (GhcPass _) = NoExtField +type instance XIParamTy (GhcPass _) = NoExtField +type instance XStarTy (GhcPass _) = NoExtField +type instance XKindSig (GhcPass _) = NoExtField + +type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives + +type instance XSpliceTy GhcPs = NoExtField +type instance XSpliceTy GhcRn = NoExtField +type instance XSpliceTy GhcTc = Kind + +type instance XDocTy (GhcPass _) = NoExtField +type instance XBangTy (GhcPass _) = NoExtField +type instance XRecTy (GhcPass _) = NoExtField + +type instance XExplicitListTy GhcPs = NoExtField +type instance XExplicitListTy GhcRn = NoExtField +type instance XExplicitListTy GhcTc = Kind + +type instance XExplicitTupleTy GhcPs = NoExtField +type instance XExplicitTupleTy GhcRn = NoExtField +type instance XExplicitTupleTy GhcTc = [Kind] + +type instance XTyLit (GhcPass _) = NoExtField + +type instance XWildCardTy (GhcPass _) = NoExtField + +type instance XXType (GhcPass _) = NewHsTypeX + + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +-- | Haskell Type Literal +data HsTyLit + = HsNumTy SourceText Integer + | HsStrTy SourceText FastString + deriving Data + + +{- +Note [HsForAllTy tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After parsing: + * Implicit => empty + Explicit => the variables the user wrote + +After renaming + * Implicit => the *type* variables free in the type + Explicit => the variables the user wrote (renamed) + +Qualified currently behaves exactly as Implicit, +but it is deprecated to use it for implicit quantification. +In this case, GHC 7.10 gives a warning; see +Note [Context quantification] in RnTypes, and #4426. +In GHC 8.0, Qualified will no longer bind variables +and this will become an error. + +The kind variables bound in the hsq_implicit field come both + a) from the kind signatures on the kind vars (eg k1) + b) from the scope of the forall (eg k2) +Example: f :: forall (a::k1) b. T a (b::k2) + + +Note [Unit tuples] +~~~~~~~~~~~~~~~~~~ +Consider the type + type instance F Int = () +We want to parse that "()" + as HsTupleTy HsBoxedOrConstraintTuple [], +NOT as HsTyVar unitTyCon + +Why? Because F might have kind (* -> Constraint), so we when parsing we +don't know if that tuple is going to be a constraint tuple or an ordinary +unit tuple. The HsTupleSort flag is specifically designed to deal with +that, but it has to work for unit tuples too. + +Note [Promotions (HsTyVar)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsTyVar: A name in a type or kind. + Here are the allowed namespaces for the name. + In a type: + Var: not allowed + Data: promoted data constructor + Tv: type variable + TcCls before renamer: type constructor, class constructor, or promoted data constructor + TcCls after renamer: type constructor or class constructor + In a kind: + Var, Data: not allowed + Tv: kind variable + TcCls: kind constructor or promoted type constructor + + The 'Promoted' field in an HsTyVar captures whether the type was promoted in + the source code by prefixing an apostrophe. + +Note [HsStarTy] +~~~~~~~~~~~~~~~ +When the StarIsType extension is enabled, we want to treat '*' and its Unicode +variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser +would mean that when we pretty-print it back, we don't know whether the user +wrote '*' or 'Type', and lose the parse/ppr roundtrip property. + +As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') +and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type). +When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not +involved. + + +Note [Promoted lists and tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice the difference between + HsListTy HsExplicitListTy + HsTupleTy HsExplicitListTupleTy + +E.g. f :: [Int] HsListTy + + g3 :: T '[] All these use + g2 :: T '[True] HsExplicitListTy + g1 :: T '[True,False] + g1a :: T [True,False] (can omit ' where unambiguous) + + kind of T :: [Bool] -> * This kind uses HsListTy! + +E.g. h :: (Int,Bool) HsTupleTy; f is a pair + k :: S '(True,False) HsExplicitTypleTy; S is indexed by + a type-level pair of booleans + kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy + +Note [Distinguishing tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Apart from promotion, tuples can have one of three different kinds: + + x :: (Int, Bool) -- Regular boxed tuples + f :: Int# -> (# Int#, Int# #) -- Unboxed tuples + g :: (Eq a, Ord a) => a -- Constraint tuples + +For convenience, internally we use a single constructor for all of these, +namely HsTupleTy, but keep track of the tuple kind (in the first argument to +HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, +because of the #. However, with -XConstraintKinds we can only distinguish +between constraint and boxed tuples during type checking, in general. Hence the +four constructors of HsTupleSort: + + HsUnboxedTuple -> Produced by the parser + HsBoxedTuple -> Certainly a boxed tuple + HsConstraintTuple -> Certainly a constraint tuple + HsBoxedOrConstraintTuple -> Could be a boxed or a constraint + tuple. Produced by the parser only, + disappears after type checking +-} + +-- | Haskell Tuple Sort +data HsTupleSort = HsUnboxedTuple + | HsBoxedTuple + | HsConstraintTuple + | HsBoxedOrConstraintTuple + deriving Data + +-- | Located Constructor Declaration Field +type LConDeclField pass = Located (ConDeclField pass) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | Constructor Declaration Field +data ConDeclField pass -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_ext :: XConDeclField pass, + cd_fld_names :: [LFieldOcc pass], + -- ^ See Note [ConDeclField passs] + cd_fld_type :: LBangType pass, + cd_fld_doc :: Maybe LHsDocString } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XConDeclField (XXConDeclField pass) + +type instance XConDeclField (GhcPass _) = NoExtField +type instance XXConDeclField (GhcPass _) = NoExtCon + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ConDeclField p) where + ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty + ppr (XConDeclField x) = ppr x + +-- HsConDetails is used for patterns/expressions *and* for data type +-- declarations +-- | Haskell Constructor Details +data HsConDetails arg rec + = PrefixCon [arg] -- C p1 p2 p3 + | RecCon rec -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + deriving Data + +instance (Outputable arg, Outputable rec) + => Outputable (HsConDetails arg rec) where + ppr (PrefixCon args) = text "PrefixCon" <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] + +hsConDetailsArgs :: + HsConDetails (LHsType a) (Located [LConDeclField a]) + -> [LHsType a] +hsConDetailsArgs details = case details of + InfixCon a b -> [a,b] + PrefixCon xs -> xs + RecCon r -> map (cd_fld_type . unLoc) (unLoc r) + +{- +Note [ConDeclField passs] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +A ConDeclField contains a list of field occurrences: these always +include the field label as the user wrote it. After the renamer, it +will additionally contain the identity of the selector function in the +second component. + +Due to DuplicateRecordFields, the OccName of the selector function +may have been mangled, which is why we keep the original field label +separately. For example, when DuplicateRecordFields is enabled + + data T = MkT { x :: Int } + +gives + + ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. +-} + +----------------------- +-- A valid type must have a for-all at the top of the type, or of the fn arg +-- types + +--------------------- +hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] +-- Get the lexically-scoped type variables of a HsSigType +-- - the explicitly-given forall'd type variables +-- - the named wildcars; see Note [Scoping of named wildcards] +-- because they scope in the same way +hsWcScopedTvs sig_ty + | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty + , HsIB { hsib_ext = vars + , hsib_body = sig_ty2 } <- sig_ty1 + = case sig_ty2 of + L _ (HsForAllTy { hst_fvf = vis_flag + , hst_bndrs = tvs }) -> + ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] + vars ++ nwcs ++ hsLTyVarNames tvs + _ -> nwcs +hsWcScopedTvs (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec +hsWcScopedTvs (XHsWildCardBndrs nec) = noExtCon nec + +hsScopedTvs :: LHsSigType GhcRn -> [Name] +-- Same as hsWcScopedTvs, but for a LHsSigType +hsScopedTvs sig_ty + | HsIB { hsib_ext = vars + , hsib_body = sig_ty2 } <- sig_ty + , L _ (HsForAllTy { hst_fvf = vis_flag + , hst_bndrs = tvs }) <- sig_ty2 + = ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] + vars ++ hsLTyVarNames tvs + | otherwise + = [] + +{- Note [Scoping of named wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: _a -> _a + f x = let g :: _a -> _a + g = ... + in ... + +Currently, for better or worse, the "_a" variables are all the same. So +although there is no explicit forall, the "_a" scopes over the definition. +I don't know if this is a good idea, but there it is. +-} + +{- Note [hsScopedTvs vis_flag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-XScopedTypeVariables can be defined in terms of a desugaring to +-XTypeAbstractions (GHC Proposal #50): + + fn :: forall a b c. tau(a,b,c) fn :: forall a b c. tau(a,b,c) + fn = defn(a,b,c) ==> fn @x @y @z = defn(x,y,z) + +That is, for every type variable of the leading 'forall' in the type signature, +we add an invisible binder at term level. + +This model does not extend to visible forall, as discussed here: + +* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412 +* https://github.com/ghc-proposals/ghc-proposals/pull/238 + +The conclusion of these discussions can be summarized as follows: + + > Assuming support for visible 'forall' in terms, consider this example: + > + > vfn :: forall x y -> tau(x,y) + > vfn = \a b -> ... + > + > The user has written their own binders 'a' and 'b' to stand for 'x' and + > 'y', and we definitely should not desugar this into: + > + > vfn :: forall x y -> tau(x,y) + > vfn x y = \a b -> ... -- bad! + +At the moment, GHC does not support visible 'forall' in terms, so we simply cement +our assumptions with an assert: + + hsScopedTvs (HsForAllTy { hst_fvf = vis_flag, ... }) = + ASSERT( vis_flag == ForallInvis ) + ... + +In the future, this assert can be safely turned into a pattern match to support +visible forall in terms: + + hsScopedTvs (HsForAllTy { hst_fvf = ForallInvis, ... }) = ... +-} + +--------------------- +hsTyVarName :: HsTyVarBndr (GhcPass p) -> IdP (GhcPass p) +hsTyVarName (UserTyVar _ (L _ n)) = n +hsTyVarName (KindedTyVar _ (L _ n) _) = n +hsTyVarName (XTyVarBndr nec) = noExtCon nec + +hsLTyVarName :: LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p) +hsLTyVarName = hsTyVarName . unLoc + +hsLTyVarNames :: [LHsTyVarBndr (GhcPass p)] -> [IdP (GhcPass p)] +hsLTyVarNames = map hsLTyVarName + +hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] +-- Explicit variables only +hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) + +hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] +-- All variables +hsAllLTyVarNames (HsQTvs { hsq_ext = kvs + , hsq_explicit = tvs }) + = kvs ++ hsLTyVarNames tvs +hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec + +hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) +hsLTyVarLocName = onHasSrcSpan hsTyVarName + +hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] +hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) + +-- | Convert a LHsTyVarBndr to an equivalent LHsType. +hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) +hsLTyVarBndrToType = onHasSrcSpan cvt + where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n + cvt (KindedTyVar _ (L name_loc n) kind) + = HsKindSig noExtField + (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind + cvt (XTyVarBndr nec) = noExtCon nec + +-- | Convert a LHsTyVarBndrs to a list of types. +-- Works on *type* variable only, no kind vars. +hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] +hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs +hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec + +--------------------- +ignoreParens :: LHsType pass -> LHsType pass +ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty +ignoreParens ty = ty + +isLHsForAllTy :: LHsType p -> Bool +isLHsForAllTy (L _ (HsForAllTy {})) = True +isLHsForAllTy _ = False + +{- +************************************************************************ +* * + Building types +* * +************************************************************************ +-} + +mkAnonWildCardTy :: HsType GhcPs +mkAnonWildCardTy = HsWildCardTy noExtField + +mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) + -> LHsType (GhcPass p) -> HsType (GhcPass p) +mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2 + +mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +mkHsAppTy t1 t2 + = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) + +mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] + -> LHsType (GhcPass p) +mkHsAppTys = foldl' mkHsAppTy + +mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) + -> LHsType (GhcPass p) +mkHsAppKindTy ext ty k + = addCLoc ty k (HsAppKindTy ext ty k) + +{- +************************************************************************ +* * + Decomposing HsTypes +* * +************************************************************************ +-} + +--------------------------------- +-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) +-- Breaks up any parens in the result type: +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) +-- Also deals with (->) t1 t2; that is why it only works on LHsType Name +-- (see #9096) +splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) +splitHsFunType (L _ (HsParTy _ ty)) + = splitHsFunType ty + +splitHsFunType (L _ (HsFunTy _ x y)) + | (args, res) <- splitHsFunType y + = (x:args, res) +{- This is not so correct, because it won't work with visible kind app, in case + someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing + ConDeclGADT abstract syntax -} +splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) + = go t1 [t2] + where -- Look for (->) t1 t2, possibly with parenthesisation + go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName + , [t1,t2] <- tys + , (args, res) <- splitHsFunType t2 + = (t1:args, res) + go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys) + go (L _ (HsParTy _ ty)) tys = go ty tys + go _ _ = ([], orig_ty) -- Failure to match + +splitHsFunType other = ([], other) + +-- retrieve the name of the "head" of a nested type application +-- somewhat like splitHsAppTys, but a little more thorough +-- used to examine the result of a GADT-like datacon, so it doesn't handle +-- *all* cases (like lists, tuples, (~), etc.) +hsTyGetAppHead_maybe :: LHsType (GhcPass p) + -> Maybe (Located (IdP (GhcPass p))) +hsTyGetAppHead_maybe = go + where + go (L _ (HsTyVar _ _ ln)) = Just ln + go (L _ (HsAppTy _ l _)) = go l + go (L _ (HsAppKindTy _ t _)) = go t + go (L _ (HsOpTy _ _ (L loc n) _)) = Just (L loc n) + go (L _ (HsParTy _ t)) = go t + go (L _ (HsKindSig _ t _)) = go t + go _ = Nothing + +------------------------------------------------------------ +-- Arguments in an expression/type after splitting +data HsArg tm ty + = HsValArg tm -- Argument is an ordinary expression (f arg) + | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) + -- SrcSpan is location of the `@` + | HsArgPar SrcSpan -- See Note [HsArgPar] + +numVisibleArgs :: [HsArg tm ty] -> Arity +numVisibleArgs = count is_vis + where is_vis (HsValArg _) = True + is_vis _ = False + +-- type level equivalent +type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) + +instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where + ppr (HsValArg tm) = ppr tm + ppr (HsTypeArg _ ty) = char '@' <> ppr ty + ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp +{- +Note [HsArgPar] +A HsArgPar indicates that everything to the left of this in the argument list is +enclosed in parentheses together with the function itself. It is necessary so +that we can recreate the parenthesis structure in the original source after +typechecking the arguments. + +The SrcSpan is the span of the original HsPar + +((f arg1) arg2 arg3) results in an input argument list of +[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] + +-} + +-------------------------------- + +-- | Decompose a pattern synonym type signature into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsPatSynTy :: LHsType pass + -> ( [LHsTyVarBndr pass] -- universals + , LHsContext pass -- required constraints + , [LHsTyVarBndr pass] -- existentials + , LHsContext pass -- provided constraints + , LHsType pass) -- body type +splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) + where + (univs, ty1) = splitLHsForAllTyInvis ty + (reqs, ty2) = splitLHsQualTy ty1 + (exis, ty3) = splitLHsForAllTyInvis ty2 + (provs, ty4) = splitLHsQualTy ty3 + +-- | Decompose a sigma type (of the form @forall . context => body@) +-- into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsSigmaTy :: LHsType pass + -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) +splitLHsSigmaTy ty + | (tvs, ty1) <- splitLHsForAllTy ty + , (ctxt, ty2) <- splitLHsQualTy ty1 + = (tvs, ctxt, ty2) + +-- | Like 'splitLHsSigmaTy', but only splits type variable binders that were +-- quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsSigmaTyInvis :: LHsType pass + -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) +splitLHsSigmaTyInvis ty + | (tvs, ty1) <- splitLHsForAllTyInvis ty + , (ctxt, ty2) <- splitLHsQualTy ty1 + = (tvs, ctxt, ty2) + +-- | Decompose a type of the form @forall . body@) into its constituent +-- parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) +splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty +splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) +splitLHsForAllTy body = ([], body) + +-- | Like 'splitLHsForAllTy', but only splits type variable binders that +-- were quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) +splitLHsForAllTyInvis lty@(L _ ty) = + case ty of + HsParTy _ ty' -> splitLHsForAllTyInvis ty' + HsForAllTy { hst_fvf = fvf', hst_bndrs = tvs', hst_body = body' } + | fvf' == ForallInvis + -> (tvs', body') + _ -> ([], lty) + +-- | Decompose a type of the form @context => body@ into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(context => <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) +splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty +splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) +splitLHsQualTy body = (noLHsContext, body) + +-- | Decompose a type class instance type (of the form +-- @forall . context => instance_head@) into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall . <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsInstDeclTy :: LHsSigType GhcRn + -> ([Name], LHsContext GhcRn, LHsType GhcRn) +-- Split up an instance decl type, returning the pieces +splitLHsInstDeclTy (HsIB { hsib_ext = itkvs + , hsib_body = inst_ty }) + | (tvs, cxt, body_ty) <- splitLHsSigmaTyInvis inst_ty + = (itkvs ++ hsLTyVarNames tvs, cxt, body_ty) + -- Return implicitly bound type and kind vars + -- For an instance decl, all of them are in scope +splitLHsInstDeclTy (XHsImplicitBndrs nec) = noExtCon nec + +getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) +getLHsInstDeclHead inst_ty + | (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty) + = body_ty + +getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) + -> Maybe (Located (IdP (GhcPass p))) +-- Works on (HsSigType RdrName) +getLHsInstDeclClass_maybe inst_ty + = do { let head_ty = getLHsInstDeclHead inst_ty + ; cls <- hsTyGetAppHead_maybe head_ty + ; return cls } + +{- +************************************************************************ +* * + FieldOcc +* * +************************************************************************ +-} + +-- | Located Field Occurrence +type LFieldOcc pass = Located (FieldOcc pass) + +-- | Field Occurrence +-- +-- Represents an *occurrence* of an unambiguous field. We store +-- both the 'RdrName' the user originally wrote, and after the +-- renamer, the selector function. +data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass + , rdrNameFieldOcc :: Located RdrName + -- ^ See Note [Located RdrNames] in GHC.Hs.Expr + } + + | XFieldOcc + (XXFieldOcc pass) +deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) +deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) + +type instance XCFieldOcc GhcPs = NoExtField +type instance XCFieldOcc GhcRn = Name +type instance XCFieldOcc GhcTc = Id + +type instance XXFieldOcc (GhcPass _) = NoExtCon + +instance Outputable (FieldOcc pass) where + ppr = ppr . rdrNameFieldOcc + +mkFieldOcc :: Located RdrName -> FieldOcc GhcPs +mkFieldOcc rdr = FieldOcc noExtField rdr + + +-- | Ambiguous Field Occurrence +-- +-- Represents an *occurrence* of a field that is potentially +-- ambiguous after the renamer, with the ambiguity resolved by the +-- typechecker. We always store the 'RdrName' that the user +-- originally wrote, and store the selector function after the renamer +-- (for unambiguous occurrences) or the typechecker (for ambiguous +-- occurrences). +-- +-- See Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat and +-- Note [Disambiguating record fields] in TcExpr. +-- See Note [Located RdrNames] in GHC.Hs.Expr +data AmbiguousFieldOcc pass + = Unambiguous (XUnambiguous pass) (Located RdrName) + | Ambiguous (XAmbiguous pass) (Located RdrName) + | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) + +type instance XUnambiguous GhcPs = NoExtField +type instance XUnambiguous GhcRn = Name +type instance XUnambiguous GhcTc = Id + +type instance XAmbiguous GhcPs = NoExtField +type instance XAmbiguous GhcRn = NoExtField +type instance XAmbiguous GhcTc = Id + +type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon + +instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where + ppr = ppr . rdrNameAmbiguousFieldOcc + +instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where + pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc + pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc + +mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs +mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr + +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName +rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr +rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr +rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc nec) + = noExtCon nec + +selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id +selectorAmbiguousFieldOcc (Unambiguous sel _) = sel +selectorAmbiguousFieldOcc (Ambiguous sel _) = sel +selectorAmbiguousFieldOcc (XAmbiguousFieldOcc nec) + = noExtCon nec + +unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc +unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel +unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel +unambiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec + +ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc +ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr +ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where + ppr ty = pprHsType ty + +instance Outputable HsTyLit where + ppr = ppr_tylit + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (LHsQTyVars p) where + ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs + ppr (XLHsQTyVars x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsTyVarBndr p) where + ppr (UserTyVar _ n) = ppr n + ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] + ppr (XTyVarBndr n) = ppr n + +instance (p ~ GhcPass pass,Outputable thing) + => Outputable (HsImplicitBndrs p thing) where + ppr (HsIB { hsib_body = ty }) = ppr ty + ppr (XHsImplicitBndrs x) = ppr x + +instance (p ~ GhcPass pass,Outputable thing) + => Outputable (HsWildCardBndrs p thing) where + ppr (HsWC { hswc_body = ty }) = ppr ty + ppr (XHsWildCardBndrs x) = ppr x + +pprAnonWildCard :: SDoc +pprAnonWildCard = char '_' + +-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ +-- only when @-dppr-debug@ is enabled. +pprHsForAll :: (OutputableBndrId (GhcPass p)) + => ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] + -> LHsContext (GhcPass p) -> SDoc +pprHsForAll = pprHsForAllExtra Nothing + +-- | Version of 'pprHsForAll' that can also print an extra-constraints +-- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This +-- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just' +-- containing the location of the extra-constraints wildcard. A special +-- function for this is needed, as the extra-constraints wildcard is removed +-- from the actual context and type, and stored in a separate field, thus just +-- printing the type will not print the extra-constraints wildcard. +pprHsForAllExtra :: (OutputableBndrId (GhcPass p)) + => Maybe SrcSpan -> ForallVisFlag + -> [LHsTyVarBndr (GhcPass p)] + -> LHsContext (GhcPass p) -> SDoc +pprHsForAllExtra extra fvf qtvs cxt + = pp_forall <+> pprLHsContextExtra (isJust extra) cxt + where + pp_forall | null qtvs = whenPprDebug (forAllLit <> separator) + | otherwise = forAllLit <+> interppSP qtvs <> separator + + separator = ppr_forall_separator fvf + +-- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print +-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing' +pprHsExplicitForAll :: (OutputableBndrId (GhcPass p)) + => ForallVisFlag + -> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc +pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs + <> ppr_forall_separator fvf +pprHsExplicitForAll _ Nothing = empty + +-- | Prints an arrow for visible @forall@s (e.g., @forall a ->@) and a dot for +-- invisible @forall@s (e.g., @forall a.@). +ppr_forall_separator :: ForallVisFlag -> SDoc +ppr_forall_separator ForallVis = space <> arrow +ppr_forall_separator ForallInvis = dot + +pprLHsContext :: (OutputableBndrId (GhcPass p)) + => LHsContext (GhcPass p) -> SDoc +pprLHsContext lctxt + | null (unLoc lctxt) = empty + | otherwise = pprLHsContextAlways lctxt + +-- For use in a HsQualTy, which always gets printed if it exists. +pprLHsContextAlways :: (OutputableBndrId (GhcPass p)) + => LHsContext (GhcPass p) -> SDoc +pprLHsContextAlways (L _ ctxt) + = case ctxt of + [] -> parens empty <+> darrow + [L _ ty] -> ppr_mono_ty ty <+> darrow + _ -> parens (interpp'SP ctxt) <+> darrow + +-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ +pprLHsContextExtra :: (OutputableBndrId (GhcPass p)) + => Bool -> LHsContext (GhcPass p) -> SDoc +pprLHsContextExtra show_extra lctxt@(L _ ctxt) + | not show_extra = pprLHsContext lctxt + | null ctxt = char '_' <+> darrow + | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow + where + ctxt' = map ppr ctxt ++ [char '_'] + +pprConDeclFields :: (OutputableBndrId (GhcPass p)) + => [LConDeclField (GhcPass p)] -> SDoc +pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) + where + ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, + cd_fld_doc = doc })) + = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + ppr_fld (L _ (XConDeclField x)) = ppr x + ppr_names [n] = ppr n + ppr_names ns = sep (punctuate comma (map ppr ns)) + +{- +Note [Printing KindedTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#3830 reminded me that we should really only print the kind +signature on a KindedTyVar if the kind signature was put there by the +programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, +rather than converting to KindedTyVars as before. + +(As it happens, the message in #3830 comes out a different way now, +and the problem doesn't show up; but having the flag on a KindedTyVar +seems like the Right Thing anyway.) +-} + +-- Printing works more-or-less as for Types + +pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc +pprHsType ty = ppr_mono_ty ty + +ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc +ppr_mono_lty ty = ppr_mono_ty (unLoc ty) + +ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc +ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }) + = sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty] + +ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) + = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] + +ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty +ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds +ppr_mono_ty (HsTyVar _ prom (L _ name)) + | isPromoted prom = quote (pprPrefixOcc name) + | otherwise = pprPrefixOcc name +ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 +ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys) + where std_con = case con of + HsUnboxedTuple -> UnboxedTuple + _ -> BoxedTuple +ppr_mono_ty (HsSumTy _ tys) + = tupleParens UnboxedTuple (pprWithBars ppr tys) +ppr_mono_ty (HsKindSig _ ty kind) + = ppr_mono_lty ty <+> dcolon <+> ppr kind +ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) +ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) +ppr_mono_ty (HsSpliceTy _ s) = pprSplice s +ppr_mono_ty (HsExplicitListTy _ prom tys) + | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) + | otherwise = brackets (interpp'SP tys) +ppr_mono_ty (HsExplicitTupleTy _ tys) + = quote $ parens (maybeAddSpace tys $ interpp'SP tys) +ppr_mono_ty (HsTyLit _ t) = ppr_tylit t +ppr_mono_ty (HsWildCardTy {}) = char '_' + +ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) + = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] +ppr_mono_ty (HsAppKindTy _ ty k) + = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k +ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) + = sep [ ppr_mono_lty ty1 + , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] + +ppr_mono_ty (HsParTy _ ty) + = parens (ppr_mono_lty ty) + -- Put the parens in where the user did + -- But we still use the precedence stuff to add parens because + -- toHsType doesn't put in any HsParTys, so we may still need them + +ppr_mono_ty (HsDocTy _ ty doc) + -- AZ: Should we add parens? Should we introduce "-- ^"? + = ppr_mono_lty ty <+> ppr (unLoc doc) + -- we pretty print Haddock comments on types as if they were + -- postfix operators + +ppr_mono_ty (XHsType t) = ppr t + +-------------------------- +ppr_fun_ty :: (OutputableBndrId (GhcPass p)) + => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc +ppr_fun_ty ty1 ty2 + = let p1 = ppr_mono_lty ty1 + p2 = ppr_mono_lty ty2 + in + sep [p1, arrow <+> p2] + +-------------------------- +ppr_tylit :: HsTyLit -> SDoc +ppr_tylit (HsNumTy _ i) = integer i +ppr_tylit (HsStrTy _ s) = text (show s) + + +-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses +-- under precedence @p@. +hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool +hsTypeNeedsParens p = go + where + go (HsForAllTy{}) = p >= funPrec + go (HsQualTy{}) = p >= funPrec + go (HsBangTy{}) = p > topPrec + go (HsRecTy{}) = False + go (HsTyVar{}) = False + go (HsFunTy{}) = p >= funPrec + go (HsTupleTy{}) = False + go (HsSumTy{}) = False + go (HsKindSig{}) = p >= sigPrec + go (HsListTy{}) = False + go (HsIParamTy{}) = p > topPrec + go (HsSpliceTy{}) = False + go (HsExplicitListTy{}) = False + go (HsExplicitTupleTy{}) = False + go (HsTyLit{}) = False + go (HsWildCardTy{}) = False + go (HsStarTy{}) = False + go (HsAppTy{}) = p >= appPrec + go (HsAppKindTy{}) = p >= appPrec + go (HsOpTy{}) = p >= opPrec + go (HsParTy{}) = False + go (HsDocTy _ (L _ t) _) = go t + go (XHsType{}) = False + +maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc +-- See Note [Printing promoted type constructors] +-- in IfaceType. This code implements the same +-- logic for printing HsType +maybeAddSpace tys doc + | (ty : _) <- tys + , lhsTypeHasLeadingPromotionQuote ty = space <> doc + | otherwise = doc + +lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool +lhsTypeHasLeadingPromotionQuote ty + = goL ty + where + goL (L _ ty) = go ty + + go (HsForAllTy{}) = False + go (HsQualTy{ hst_ctxt = ctxt, hst_body = body}) + | L _ (c:_) <- ctxt = goL c + | otherwise = goL body + go (HsBangTy{}) = False + go (HsRecTy{}) = False + go (HsTyVar _ p _) = isPromoted p + go (HsFunTy _ arg _) = goL arg + go (HsListTy{}) = False + go (HsTupleTy{}) = False + go (HsSumTy{}) = False + go (HsOpTy _ t1 _ _) = goL t1 + go (HsKindSig _ t _) = goL t + go (HsIParamTy{}) = False + go (HsSpliceTy{}) = False + go (HsExplicitListTy _ p _) = isPromoted p + go (HsExplicitTupleTy{}) = True + go (HsTyLit{}) = False + go (HsWildCardTy{}) = False + go (HsStarTy{}) = False + go (HsAppTy _ t _) = goL t + go (HsAppKindTy _ t _) = goL t + go (HsParTy{}) = False + go (HsDocTy _ t _) = goL t + go (XHsType{}) = False + +-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is +-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply +-- returns @ty@. +parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) +parenthesizeHsType p lty@(L loc ty) + | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty) + | otherwise = lty + +-- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint +-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ +-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply +-- returns @ctxt@ unchanged. +parenthesizeHsContext :: PprPrec + -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) +parenthesizeHsContext p lctxt@(L loc ctxt) = + case ctxt of + [c] -> L loc [parenthesizeHsType p c] + _ -> lctxt -- Other contexts are already "parenthesized" by virtue of + -- being tuples. diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs new file mode 100644 index 0000000000..5d54196af2 --- /dev/null +++ b/compiler/GHC/Hs/Utils.hs @@ -0,0 +1,1416 @@ +{- +(c) The University of Glasgow, 1992-2006 + + +Here we collect a variety of helper functions that construct or +analyse HsSyn. All these functions deal with generic HsSyn; functions +which deal with the instantiated versions are located elsewhere: + + Parameterised by Module + ---------------- ------------- + GhcPs/RdrName parser/RdrHsSyn + GhcRn/Name rename/RnHsSyn + GhcTc/Id typecheck/TcHsSyn +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Hs.Utils( + -- Terms + mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt, + mkSimpleMatch, unguardedGRHSs, unguardedRHS, + mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, + mkHsDictLet, mkHsLams, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, + mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, + mkHsCmdIf, + + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, + nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, + nlHsIntLit, nlHsVarApps, + nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, + mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, + typeToLHsType, + + -- * Constructing general big tuples + -- $big_tuples + mkChunkified, chunkify, + + -- Bindings + mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, + mkPatSynBind, + isInfixFunBind, + + -- Literals + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, + + -- Patterns + mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, + nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, + nlWildPatName, nlTuplePat, mkParPat, nlParPat, + mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, + + -- Types + mkHsAppTy, mkHsAppKindTy, + mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv, + nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, + + -- Stmts + mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt, + mkLastStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, + emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, + unitRecStmtTc, + + -- Template Haskell + mkUntypedSplice, mkTypedSplice, + mkHsQuasiQuote, unqualQuasiQuote, + + -- Collecting binders + isUnliftedHsBind, isBangedHsBind, + + collectLocalBinders, collectHsValBinders, collectHsBindListBinders, + collectHsIdBinders, + collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, + collectPatBinders, collectPatsBinders, + collectLStmtsBinders, collectStmtsBinders, + collectLStmtBinders, collectStmtBinders, + + hsLTyClDeclBinders, hsTyClForeignBinders, + hsPatSynSelectors, getPatSynBinds, + hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr +import GHC.Hs.Pat +import GHC.Hs.Types +import GHC.Hs.Lit +import GHC.Hs.PlaceHolder +import GHC.Hs.Extension + +import TcEvidence +import RdrName +import Var +import TyCoRep +import Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) +import TysWiredIn ( unitTy ) +import TcType +import DataCon +import ConLike +import Id +import Name +import NameSet hiding ( unitFV ) +import NameEnv +import BasicTypes +import SrcLoc +import FastString +import Util +import Bag +import Outputable +import Constants + +import Data.Either +import Data.Function +import Data.List + +{- +************************************************************************ +* * + Some useful helpers for constructing syntax +* * +************************************************************************ + +These functions attempt to construct a not-completely-useless SrcSpan +from their components, compared with the nl* functions below which +just attach noSrcSpan to everything. +-} + +mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsPar e = cL (getLoc e) (HsPar noExtField e) + +mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) + -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) + -> LMatch (GhcPass p) (Located (body (GhcPass p))) +mkSimpleMatch ctxt pats rhs + = cL loc $ + Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats + , m_grhss = unguardedGRHSs rhs } + where + loc = case pats of + [] -> getLoc rhs + (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) + +unguardedGRHSs :: Located (body (GhcPass p)) + -> GRHSs (GhcPass p) (Located (body (GhcPass p))) +unguardedGRHSs rhs@(dL->L loc _) + = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds) + +unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) + -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] +unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)] + +mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField) + => Origin -> [LMatch name (Located (body name))] + -> MatchGroup name (Located (body name)) +mkMatchGroup origin matches = MG { mg_ext = noExtField + , mg_alts = mkLocatedList matches + , mg_origin = origin } + +mkLocatedList :: [Located a] -> Located [Located a] +mkLocatedList [] = noLoc [] +mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms + +mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2) + +mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn) + => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id) +mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) + where + t_body = hswc_body t + paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } + +mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn +mkHsAppTypes = foldl' mkHsAppType + +mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => + [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches)) + where + matches = mkMatchGroup Generated + [mkSimpleMatch LambdaExpr pats' body] + pats' = map (parenthesizePat appPrec) pats + +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars + <.> mkWpLams dicts) expr + +-- |A simple case alternative with a single pattern, no binds, no guards; +-- pre-typechecking +mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) + -> LMatch (GhcPass p) (Located (body (GhcPass p))) +mkHsCaseAlt pat expr + = mkSimpleMatch CaseAlt [pat] expr + +nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) +nlHsTyApp fun_id tys + = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id))) + +nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) +nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs + +--------- Adding parens --------- +mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +-- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them +-- So 'f x' becomes '(f x)', but '3' stays as '3' +mkLHsPar le@(dL->L loc e) + | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le) + | otherwise = le + +mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) +mkParPat lp@(dL->L loc p) + | patNeedsParens appPrec p = cL loc (ParPat noExtField lp) + | otherwise = lp + +nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) +nlParPat p = noLoc (ParPat noExtField p) + +------------------------------- +-- These are the bits of syntax that contain rebindable names +-- See RnEnv.lookupSyntaxName + +mkHsIntegral :: IntegralLit -> HsOverLit GhcPs +mkHsFractional :: FractionalLit -> HsOverLit GhcPs +mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs +mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> HsExpr GhcPs + +mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) + -> Pat GhcPs +mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs + +mkLastStmt :: Located (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) +mkBodyStmt :: Located (bodyR GhcPs) + -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) +mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR) + (Located (bodyR (GhcPass idR))) ~ NoExtField) + => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) +mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) + -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) + +emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR +emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR +emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR +mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR] + -> StmtLR (GhcPass idL) GhcPs bodyR + + +mkHsIntegral i = OverLit noExtField (HsIntegral i) noExpr +mkHsFractional f = OverLit noExtField (HsFractional f) noExpr +mkHsIsString src s = OverLit noExtField (HsIsString src s) noExpr + +mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts) +mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) + where + last_stmt = cL (getLoc expr) $ mkLastStmt expr + +mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) + -> HsExpr (GhcPass p) +mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b + +mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) + -> HsCmd (GhcPass p) +mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b + +mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr +mkNPlusKPat id lit + = NPlusKPat noExtField id lit (unLoc lit) noSyntaxExpr noSyntaxExpr + +mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) + +emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) +emptyTransStmt = TransStmt { trS_ext = noExtField + , trS_form = panic "emptyTransStmt: form" + , trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLoc noExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noExpr } +mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } + +mkLastStmt body = LastStmt noExtField body False noSyntaxExpr +mkBodyStmt body + = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr +mkBindStmt pat body + = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr +mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr + -- don't use placeHolderTypeTc above, because that panics during zonking + +emptyRecStmt' :: forall idL idR body. + XRecStmt (GhcPass idL) (GhcPass idR) body + -> StmtLR (GhcPass idL) (GhcPass idR) body +emptyRecStmt' tyVal = + RecStmt + { recS_stmts = [], recS_later_ids = [] + , recS_rec_ids = [] + , recS_ret_fn = noSyntaxExpr + , recS_mfix_fn = noSyntaxExpr + , recS_bind_fn = noSyntaxExpr + , recS_ext = tyVal } + +unitRecStmtTc :: RecStmtTc +unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy + , recS_later_rets = [] + , recS_rec_rets = [] + , recS_ret_ty = unitTy } + +emptyRecStmt = emptyRecStmt' noExtField +emptyRecStmtName = emptyRecStmt' noExtField +emptyRecStmtId = emptyRecStmt' unitRecStmtTc + -- a panic might trigger during zonking +mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } + +------------------------------- +--- A useful function for building @OpApps@. The operator is always a +-- variable, and we don't know the fixity yet. +mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs +mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLoc (HsVar noExtField (noLoc op))) e2 + +unqualSplice :: RdrName +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) + +mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs +mkUntypedSplice hasParen e = HsUntypedSplice noExtField hasParen unqualSplice e + +mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs +mkTypedSplice hasParen e = HsTypedSplice noExtField hasParen unqualSplice e + +mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs +mkHsQuasiQuote quoter span quote + = HsQuasiQuote noExtField unqualSplice quoter span quote + +unqualQuasiQuote :: RdrName +unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) + -- A name (uniquified later) to + -- identify the quasi-quote + +mkHsString :: String -> HsLit (GhcPass p) +mkHsString s = HsString NoSourceText (mkFastString s) + +mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) +mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) + + +{- +************************************************************************ +* * + Constructing syntax with no location info +* * +************************************************************************ +-} + +nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) +nlHsVar n = noLoc (HsVar noExtField (noLoc n)) + +-- NB: Only for LHsExpr **Id** +nlHsDataCon :: DataCon -> LHsExpr GhcTc +nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con)) + +nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) +nlHsLit n = noLoc (HsLit noExtField n) + +nlHsIntLit :: Integer -> LHsExpr (GhcPass p) +nlHsIntLit n = noLoc (HsLit noExtField (HsInt noExtField (mkIntegralLit n))) + +nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) +nlVarPat n = noLoc (VarPat noExtField (noLoc n)) + +nlLitPat :: HsLit GhcPs -> LPat GhcPs +nlLitPat l = noLoc (LitPat noExtField l) + +nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x)) + +nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) +nlHsSyntaxApps (SyntaxExpr { syn_expr = fun + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) args + | [] <- arg_wraps -- in the noSyntaxExpr case + = ASSERT( isIdHsWrapper res_wrap ) + foldl' nlHsApp (noLoc fun) args + + | otherwise + = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" + mkLHsWrap arg_wraps args)) + +nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs + +nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExtField (noLoc f)) + (map ((HsVar noExtField) . noLoc) xs)) + where + mk f a = HsApp noExtField (noLoc f) (noLoc a) + +nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs +nlConVarPat con vars = nlConPat con (map nlVarPat vars) + +nlConVarPatName :: Name -> [Name] -> LPat GhcRn +nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) + +nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs +nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) + (InfixCon (parenthesizePat opPrec l) + (parenthesizePat opPrec r))) + +nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs +nlConPat con pats = + noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) + +nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn +nlConPatName con pats = + noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) + +nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p) +nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) + +nlWildConPat :: DataCon -> LPat GhcPs +nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) + (PrefixCon (replicate (dataConSourceArity con) + nlWildPat))) + +nlWildPat :: LPat GhcPs +nlWildPat = noLoc (WildPat noExtField ) -- Pre-typechecking + +nlWildPatName :: LPat GhcRn +nlWildPatName = noLoc (WildPat noExtField ) -- Pre-typechecking + +nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] + -> LHsExpr GhcPs +nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) + +nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) + +nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs +nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) +nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsExpr GhcPs +nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs + +nlHsLam match = noLoc (HsLam noExtField (mkMatchGroup Generated [match])) +nlHsPar e = noLoc (HsPar noExtField e) + +-- Note [Rebindable nlHsIf] +-- nlHsIf should generate if-expressions which are NOT subject to +-- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) +nlHsIf cond true false = noLoc (HsIf noExtField Nothing cond true false) + +nlHsCase expr matches + = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches)) +nlList exprs = noLoc (ExplicitList noExtField Nothing exprs) + +nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) +nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) + +nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t)) +nlHsTyVar x = noLoc (HsTyVar noExtField NotPromoted (noLoc x)) +nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b) +nlHsParTy t = noLoc (HsParTy noExtField t) + +nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) +nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys + +nlHsAppKindTy :: + LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) +nlHsAppKindTy f k + = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k)) + +{- +Tuples. All these functions are *pre-typechecker* because they lack +types on the tuple. +-} + +mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) +-- Makes a pre-typechecker boxed tuple, deals with 1 case +mkLHsTupleExpr [e] = e +mkLHsTupleExpr es + = noLoc $ ExplicitTuple noExtField (map (noLoc . (Present noExtField)) es) Boxed + +mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) +mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) + +nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs +nlTuplePat pats box = noLoc (TuplePat noExtField pats box) + +missingTupArg :: HsTupArg GhcPs +missingTupArg = Missing noExtField + +mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed +mkLHsPatTup [lpat] = lpat +mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed + +-- The Big equivalents for the source tuple expressions +mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) +mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) + +mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +mkBigLHsTup = mkChunkified mkLHsTupleExpr + +-- The Big equivalents for the source tuple patterns +mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn +mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) + +mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkBigLHsPatTup = mkChunkified mkLHsPatTup + +-- $big_tuples +-- #big_tuples# +-- +-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but +-- we might concievably want to build such a massive tuple as part of the +-- output of a desugaring stage (notably that for list comprehensions). +-- +-- We call tuples above this size \"big tuples\", and emulate them by +-- creating and pattern matching on >nested< tuples that are expressible +-- by GHC. +-- +-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) +-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any +-- construction to be big. +-- +-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' +-- and 'mkTupleCase' functions to do all your work with tuples you should be +-- fine, and not have to worry about the arity limitation at all. + +-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon +mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' + -> [a] -- ^ Possible \"big\" list of things to construct from + -> a -- ^ Constructed thing made possible by recursive decomposition +mkChunkified small_tuple as = mk_big_tuple (chunkify as) + where + -- Each sub-list is short enough to fit in a tuple + mk_big_tuple [as] = small_tuple as + mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) + +chunkify :: [a] -> [[a]] +-- ^ Split a list into lists that are small enough to have a corresponding +-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' +-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists +chunkify xs + | n_xs <= mAX_TUPLE_SIZE = [xs] + | otherwise = split xs + where + n_xs = length xs + split [] = [] + split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) + +{- +************************************************************************ +* * + LHsSigType and LHsSigWcType +* * +********************************************************************* -} + +mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs +mkLHsSigType ty = mkHsImplicitBndrs ty + +mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs +mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty) + +mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a)) + -> [LSig GhcRn] + -> NameEnv a +mkHsSigEnv get_info sigs + = mkNameEnv (mk_pairs ordinary_sigs) + `extendNameEnvList` (mk_pairs gen_dm_sigs) + -- The subtlety is this: in a class decl with a + -- default-method signature as well as a method signature + -- we want the latter to win (#12533) + -- class C x where + -- op :: forall a . x a -> x a + -- default op :: forall b . x b -> x b + -- op x = ...(e :: b -> b)... + -- The scoped type variables of the 'default op', namely 'b', + -- scope over the code for op. The 'forall a' does not! + -- This applies both in the renamer and typechecker, both + -- of which use this function + where + (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs + is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True + is_gen_dm_sig _ = False + + mk_pairs :: [LSig GhcRn] -> [(Name, a)] + mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs + , (dL->L _ n) <- ns ] + +mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] +-- Convert TypeSig to ClassOpSig +-- The former is what is parsed, but the latter is +-- what we need in class/instance declarations +mkClassOpSigs sigs + = map fiddle sigs + where + fiddle (dL->L loc (TypeSig _ nms ty)) + = cL loc (ClassOpSig noExtField False nms (dropWildCards ty)) + fiddle sig = sig + +typeToLHsType :: Type -> LHsType GhcPs +-- ^ Converting a Type to an HsType RdrName +-- This is needed to implement GeneralizedNewtypeDeriving. +-- +-- Note that we use 'getRdrName' extensively, which +-- generates Exact RdrNames rather than strings. +typeToLHsType ty + = go ty + where + go :: Type -> LHsType GhcPs + go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + = case af of + VisArg -> nlHsFunTy (go arg) (go res) + InvisArg | (theta, tau) <- tcSplitPhiTy ty + -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) + , hst_xqual = noExtField + , hst_body = go tau }) + + go ty@(ForAllTy (Bndr _ argf) _) + | (tvs, tau) <- tcSplitForAllTysSameVis argf ty + = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf + , hst_bndrs = map go_tv tvs + , hst_xforall = noExtField + , hst_body = go tau }) + go (TyVarTy tv) = nlHsTyVar (getRdrName tv) + go (LitTy (NumTyLit n)) + = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n) + go (LitTy (StrTyLit s)) + = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s) + go ty@(TyConApp tc args) + | tyConAppNeedsKindSig True tc (length args) + -- We must produce an explicit kind signature here to make certain + -- programs kind-check. See Note [Kind signatures in typeToLHsType]. + = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty)) + | otherwise = ty' + where + ty' :: LHsType GhcPs + ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args) + go ty@(AppTy {}) = go_app (go head) args (appTyArgFlags head args) + where + head :: Type + args :: [Type] + (head, args) = splitAppTys ty + go (CastTy ty _) = go ty + go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) + + -- Source-language types have _invisible_ kind arguments, + -- so we must remove them here (#8563) + + go_app :: LHsType GhcPs -- The type being applied + -> [Type] -- The argument types + -> [ArgFlag] -- The argument types' visibilities + -> LHsType GhcPs + go_app head args arg_flags = + foldl' (\f (arg, flag) -> + let arg' = go arg in + case flag of + Inferred -> f + Specified -> f `nlHsAppKindTy` arg' + Required -> f `nlHsAppTy` arg') + head (zip args arg_flags) + + go_tv :: TyVar -> LHsTyVarBndr GhcPs + go_tv tv = noLoc $ KindedTyVar noExtField (noLoc (getRdrName tv)) + (go (tyVarKind tv)) + +{- +Note [Kind signatures in typeToLHsType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are types that typeToLHsType can produce which require explicit kind +signatures in order to kind-check. Here is an example from #14579: + + -- type P :: forall {k} {t :: k}. Proxy t + type P = 'Proxy + + -- type Wat :: forall a. Proxy a -> * + newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) + deriving Eq + + -- type Wat2 :: forall {a}. Proxy a -> * + type Wat2 = Wat + + -- type Glurp :: * -> * + newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a)) + deriving Eq + +The derived Eq instance for Glurp (without any kind signatures) would be: + + instance Eq a => Eq (Glurp a) where + (==) = coerce @(Wat2 P -> Wat2 P -> Bool) + @(Glurp a -> Glurp a -> Bool) + (==) :: Glurp a -> Glurp a -> Bool + +(Where the visible type applications use types produced by typeToLHsType.) + +The type P (in Wat2 P) has an underspecified kind, so we must ensure that +typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish +this, whenever we see an application of a tycon to some arguments, we use +the tyConAppNeedsKindSig function to determine if it requires an explicit kind +signature to resolve some ambiguity. (See Note +Note [When does a tycon application need an explicit kind signature?] for a +more detailed explanation of how this works.) + +Note that we pass True to tyConAppNeedsKindSig since we are generated code with +visible kind applications, so even specified arguments count towards injective +positions in the kind of the tycon. +-} + +{- ********************************************************************* +* * + --------- HsWrappers: type args, dict args, casts --------- +* * +********************************************************************* -} + +mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) + +-- Avoid (HsWrap co (HsWrap co' _)). +-- See Note [Detecting forced eta expansion] in DsExpr +mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) +mkHsWrap co_fn e | isIdHsWrapper co_fn = e +mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e +mkHsWrap co_fn e = HsWrap noExtField co_fn e + +mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b + -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) +mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e + +mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b + -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) +mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e + +mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) + +mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) +mkHsCmdWrap w cmd | isIdHsWrapper w = cmd + | otherwise = HsCmdWrap noExtField w cmd + +mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) +mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) + +mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p + | otherwise = CoPat noExtField co_fn p ty + +mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPatCo co pat ty | isTcReflCo co = pat + | otherwise = CoPat noExtField (mkWpCastN co) pat ty + +mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr + +{- +l +************************************************************************ +* * + Bindings; with a location at the top +* * +************************************************************************ +-} + +mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs +-- Not infix, with place holders for coercion and free vars +mkFunBind fn ms = FunBind { fun_id = fn + , fun_matches = mkMatchGroup Generated ms + , fun_co_fn = idHsWrapper + , fun_ext = noExtField + , fun_tick = [] } + +mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] + -> HsBind GhcRn +-- In Name-land, with empty bind_fvs +mkTopFunBind origin fn ms = FunBind { fun_id = fn + , fun_matches = mkMatchGroup origin ms + , fun_co_fn = idHsWrapper + , fun_ext = emptyNameSet -- NB: closed + -- binding + , fun_tick = [] } + +mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs +mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs + +mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) +mkVarBind var rhs = cL (getLoc rhs) $ + VarBind { var_ext = noExtField, + var_id = var, var_rhs = rhs, var_inline = False } + +mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) + -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs +mkPatSynBind name details lpat dir = PatSynBind noExtField psb + where + psb = PSB{ psb_ext = noExtField + , psb_id = name + , psb_args = details + , psb_def = lpat + , psb_dir = dir } + +-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is +-- considered infix. +isInfixFunBind :: HsBindLR id1 id2 -> Bool +isInfixFunBind (FunBind _ _ (MG _ matches _) _ _) + = any (isInfixMatch . unLoc) (unLoc matches) +isInfixFunBind _ = False + + +------------ +mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs] + -> LHsExpr GhcPs -> LHsBind GhcPs +mk_easy_FunBind loc fun pats expr + = cL loc $ mkFunBind (cL loc fun) + [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr + (noLoc emptyLocalBinds)] + +-- | Make a prefix, non-strict function 'HsMatchContext' +mkPrefixFunRhs :: Located id -> HsMatchContext id +mkPrefixFunRhs n = FunRhs { mc_fun = n + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict } + +------------ +mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) + -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) + -> Located (HsLocalBinds (GhcPass p)) + -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) +mkMatch ctxt pats expr lbinds + = noLoc (Match { m_ext = noExtField + , m_ctxt = ctxt + , m_pats = map paren pats + , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) + where + paren lp@(dL->L l p) + | patNeedsParens appPrec p = cL l (ParPat noExtField lp) + | otherwise = lp + +{- +************************************************************************ +* * + Collecting binders +* * +************************************************************************ + +Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. + +... +where + (x, y) = ... + f i j = ... + [a, b] = ... + +it should return [x, y, f, a, b] (remember, order important). + +Note [Collect binders only after renaming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions should only be used on HsSyn *after* the renamer, +to return a [Name] or [Id]. Before renaming the record punning +and wild-card mechanism makes it hard to know what is bound. +So these functions should not be applied to (HsSyn RdrName) + +Note [Unlifted id check in isUnliftedHsBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function isUnliftedHsBind is used to complain if we make a top-level +binding for a variable of unlifted type. + +Such a binding is illegal if the top-level binding would be unlifted; +but also if the local letrec generated by desugaring AbsBinds would be. +E.g. + f :: Num a => (# a, a #) + g :: Num a => a -> a + f = ...g... + g = ...g... + +The top-level bindings for f,g are not unlifted (because of the Num a =>), +but the local, recursive, monomorphic bindings are: + + t = /\a \(d:Num a). + letrec fm :: (# a, a #) = ...g... + gm :: a -> a = ...f... + in (fm, gm) + +Here the binding for 'fm' is illegal. So generally we check the abe_mono types. + +BUT we have a special case when abs_sig is true; + see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds +-} + +----------------- Bindings -------------------------- + +-- | Should we treat this as an unlifted bind? This will be true for any +-- bind that binds an unlifted variable, but we must be careful around +-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage +-- information, see Note [Strict binds check] is DsBinds. +isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds +isUnliftedHsBind bind + | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind + = if has_sig + then any (is_unlifted_id . abe_poly) exports + else any (is_unlifted_id . abe_mono) exports + -- If has_sig is True we wil never generate a binding for abe_mono, + -- so we don't need to worry about it being unlifted. The abe_poly + -- binding might not be: e.g. forall a. Num a => (# a, a #) + + | otherwise + = any is_unlifted_id (collectHsBindBinders bind) + where + is_unlifted_id id = isUnliftedType (idType id) + +-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? +isBangedHsBind :: HsBind GhcTc -> Bool +isBangedHsBind (AbsBinds { abs_binds = binds }) + = anyBag (isBangedHsBind . unLoc) binds +isBangedHsBind (FunBind {fun_matches = matches}) + | [dL->L _ match] <- unLoc $ mg_alts matches + , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match + = True +isBangedHsBind (PatBind {pat_lhs = pat}) + = isBangedLPat pat +isBangedHsBind _ + = False + +collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] +collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds + -- No pattern synonyms here +collectLocalBinders (HsIPBinds {}) = [] +collectLocalBinders (EmptyLocalBinds _) = [] +collectLocalBinders (XHsLocalBindsLR _) = [] + +collectHsIdBinders, collectHsValBinders + :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] +-- Collect Id binders only, or Ids + pattern synonyms, respectively +collectHsIdBinders = collect_hs_val_binders True +collectHsValBinders = collect_hs_val_binders False + +collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=> + HsBindLR p idR -> [IdP p] +-- Collect both Ids and pattern-synonym binders +collectHsBindBinders b = collect_bind False b [] + +collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] +collectHsBindsBinders binds = collect_binds False binds [] + +collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)] +-- Same as collectHsBindsBinders, but works over a list of bindings +collectHsBindListBinders = foldr (collect_bind False . unLoc) [] + +collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] +collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] +collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) + = collect_out_binds ps binds + +collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] -> + [IdP (GhcPass p)] +collect_out_binds ps = foldr (collect_binds ps . snd) [] + +collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> + [IdP (GhcPass p)] -> [IdP (GhcPass p)] +-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag +collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds + +collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] +collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc +collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc +collect_bind _ (VarBind { var_id = f }) acc = f : acc +collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc + -- I don't think we want the binders from the abe_binds + + -- binding (hence see AbsBinds) is in zonking in TcHsSyn +collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc + | omitPatSyn = acc + | otherwise = ps : acc +collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc +collect_bind _ (XHsBindsLR _) acc = acc + +collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)] +-- Used exclusively for the bindings of an instance decl which are all FunBinds +collectMethodBinders binds = foldr (get . unLoc) [] binds + where + get (FunBind { fun_id = f }) fs = f : fs + get _ fs = fs + -- Someone else complains about non-FunBinds + +----------------- Statements -------------------------- +collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] +collectStmtsBinders = concatMap collectStmtBinders + +collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] + -- Id Binders for a Stmt... [but what about pattern-sig type vars]? +collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat +collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds) +collectStmtBinders (BodyStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders + $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args + where + collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat + collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat + collectArgBinders _ = [] +collectStmtBinders (XStmtLR nec) = noExtCon nec + + +----------------- Patterns -------------------------- +collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)] +collectPatBinders pat = collect_lpat pat [] + +collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] +collectPatsBinders pats = foldr collect_lpat [] pats + +------------- +collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + LPat p -> [IdP p] -> [IdP p] +collect_lpat p bndrs + = go (unLoc p) + where + go (VarPat _ var) = unLoc var : bndrs + go (WildPat _) = bndrs + go (LazyPat _ pat) = collect_lpat pat bndrs + go (BangPat _ pat) = collect_lpat pat bndrs + go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs + go (ViewPat _ _ pat) = collect_lpat pat bndrs + go (ParPat _ pat) = collect_lpat pat bndrs + + go (ListPat _ pats) = foldr collect_lpat bndrs pats + go (TuplePat _ pats _) = foldr collect_lpat bndrs pats + go (SumPat _ pat _ _) = collect_lpat pat bndrs + + go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) + go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) + -- See Note [Dictionary binders in ConPatOut] + go (LitPat _ _) = bndrs + go (NPat {}) = bndrs + go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs + + go (SigPat _ pat _) = collect_lpat pat bndrs + + go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) + = go pat + go (SplicePat _ _) = bndrs + go (CoPat _ _ pat _) = go pat + go (XPat {}) = bndrs + +{- +Note [Dictionary binders in ConPatOut] See also same Note in DsArrows +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* gather (a) dictionary and (b) dictionary bindings as binders +of a ConPatOut pattern. For most calls it doesn't matter, because +it's pre-typechecker and there are no ConPatOuts. But it does matter +more in the desugarer; for example, DsUtils.mkSelectorBinds uses +collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., +we want to generate bindings for x,y but not for dictionaries bound by +C. (The type checker ensures they would not be used.) + +Desugaring of arrow case expressions needs these bindings (see DsArrows +and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its +own pat-binder-collector: + +Here's the problem. Consider + +data T a where + C :: Num a => a -> Int -> T a + +f ~(C (n+1) m) = (n,m) + +Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), +and *also* uses that dictionary to match the (n+1) pattern. Yet, the +variables bound by the lazy pattern are n,m, *not* the dictionary d. +So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. +-} + +hsGroupBinders :: HsGroup GhcRn -> [Name] +hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = collectHsValBinders val_decls + ++ hsTyClForeignBinders tycl_decls foreign_decls +hsGroupBinders (XHsGroup nec) = noExtCon nec + +hsTyClForeignBinders :: [TyClGroup GhcRn] + -> [LForeignDecl GhcRn] + -> [Name] +-- We need to look at instance declarations too, +-- because their associated types may bind data constructors +hsTyClForeignBinders tycl_decls foreign_decls + = map unLoc (hsForeignDeclsBinders foreign_decls) + ++ getSelectorNames + (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls + `mappend` + foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) + where + getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] + getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs + +------------------- +hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p)) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) +-- ^ Returns all the /binding/ names of the decl. The first one is +-- guaranteed to be the name of the decl. The first component +-- represents all binding names except record fields; the second +-- represents field occurrences. For record fields mentioned in +-- multiple constructors, the SrcLoc will be from the first occurrence. +-- +-- Each returned (Located name) has a SrcSpan for the /whole/ declaration. +-- See Note [SrcSpan for binders] + +hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl + { fdLName = (dL->L _ name) } })) + = ([cL loc name], []) +hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec })) + = noExtCon nec +hsLTyClDeclBinders (dL->L loc (SynDecl + { tcdLName = (dL->L _ name) })) + = ([cL loc name], []) +hsLTyClDeclBinders (dL->L loc (ClassDecl + { tcdLName = (dL->L _ cls_name) + , tcdSigs = sigs + , tcdATs = ats })) + = (cL loc cls_name : + [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl + { fdLName = L _ fam_name })) <- ats ] + ++ + [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (dL->L _ mem_name) <- ns ] + , []) +hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) + , tcdDataDefn = defn })) + = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn +hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec +hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" + -- due to #15884 + + +------------------- +hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] +-- See Note [SrcSpan for binders] +hsForeignDeclsBinders foreign_decls + = [ cL decl_loc n + | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) })) + <- foreign_decls] + + +------------------- +hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] +-- Collects record pattern-synonym selectors only; the pattern synonym +-- names are collected by collectHsValBinders. +hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (XValBindsLR (NValBinds binds _)) + = foldr addPatSynSelector [] . unionManyBags $ map snd binds + +addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] +addPatSynSelector bind sels + | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind + = map (unLoc . recordPatSynSelectorId) as ++ sels + | otherwise = sels + +getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] +getPatSynBinds binds + = [ psb | (_, lbinds) <- binds + , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ] + +------------------- +hsLInstDeclBinders :: LInstDecl (GhcPass p) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) +hsLInstDeclBinders (dL->L _ (ClsInstD + { cid_inst = ClsInstDecl + { cid_datafam_insts = dfis }})) + = foldMap (hsDataFamInstBinders . unLoc) dfis +hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) + = hsDataFamInstBinders fi +hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty +hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec))) + = noExtCon nec +hsLInstDeclBinders (dL->L _ (XInstDecl nec)) + = noExtCon nec +hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" + -- due to #15884 + +------------------- +-- the SrcLoc returned are for the whole declarations, not just the names +hsDataFamInstBinders :: DataFamInstDecl (GhcPass p) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) +hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = defn }}}) + = hsDataDefnBinders defn + -- There can't be repeated symbols because only data instances have binders +hsDataFamInstBinders (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = XFamEqn nec}}) + = noExtCon nec +hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec + +------------------- +-- the SrcLoc returned are for the whole declarations, not just the names +hsDataDefnBinders :: HsDataDefn (GhcPass p) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) +hsDataDefnBinders (HsDataDefn { dd_cons = cons }) + = hsConDeclsBinders cons + -- See Note [Binders in family instances] +hsDataDefnBinders (XHsDataDefn nec) = noExtCon nec + +------------------- +type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] + -- Filters out ones that have already been seen + +hsConDeclsBinders :: [LConDecl (GhcPass p)] + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -- See hsLTyClDeclBinders for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons + = go id cons + where + go :: Seen p -> [LConDecl (GhcPass p)] + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + go _ [] = ([], []) + go remSeen (r:rs) + -- Don't re-mangle the location of field names, because we don't + -- have a record of the full location of the field declaration anyway + = let loc = getLoc r + in case unLoc r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + ConDeclGADT { con_names = names, con_args = args } + -> (map (cL loc . unLoc) names ++ ns, flds ++ fs) + where + (remSeen', flds) = get_flds remSeen args + (ns, fs) = go remSeen' rs + + ConDeclH98 { con_name = name, con_args = args } + -> ([cL loc (unLoc name)] ++ ns, flds ++ fs) + where + (remSeen', flds) = get_flds remSeen args + (ns, fs) = go remSeen' rs + + XConDecl nec -> noExtCon nec + + get_flds :: Seen p -> HsConDeclDetails (GhcPass p) + -> (Seen p, [LFieldOcc (GhcPass p)]) + get_flds remSeen (RecCon flds) + = (remSeen', fld_names) + where + fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) + remSeen' = foldr (.) remSeen + [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v + | v <- fld_names] + get_flds remSeen _ + = (remSeen, []) + +{- + +Note [SrcSpan for binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When extracting the (Located RdrNme) for a binder, at least for the +main name (the TyCon of a type declaration etc), we want to give it +the @SrcSpan@ of the whole /declaration/, not just the name itself +(which is how it appears in the syntax tree). This SrcSpan (for the +entire declaration) is used as the SrcSpan for the Name that is +finally produced, and hence for error messages. (See #8607.) + +Note [Binders in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type or data family instance declaration, the type +constructor is an *occurrence* not a binding site + type instance T Int = Int -> Int -- No binders + data instance S Bool = S1 | S2 -- Binders are S1,S2 + + +************************************************************************ +* * + Collecting binders the user did not write +* * +************************************************************************ + +The job of this family of functions is to run through binding sites and find the set of all Names +that were defined "implicitly", without being explicitly written by the user. + +The main purpose is to find names introduced by record wildcards so that we can avoid +warning the user when they don't use those names (#4404) + +Since the addition of -Wunused-record-wildcards, this function returns a pair +of [(SrcSpan, [Name])]. Each element of the list is one set of implicit +binders, the first component of the tuple is the document describes the possible +fix to the problem (by removing the ..). + +This means there is some unfortunate coupling between this function and where it +is used but it's only used for one specific purpose in one place so it seemed +easier. +-} + +lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] + -> [(SrcSpan, [Name])] +lStmtsImplicits = hs_lstmts + where + hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] + -> [(SrcSpan, [Name])] + hs_lstmts = concatMap (hs_stmt . unLoc) + + hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) + -> [(SrcSpan, [Name])] + hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat + hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args + where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat + do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts + do_arg (_, XApplicativeArg nec) = noExtCon nec + hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) + hs_stmt (BodyStmt {}) = [] + hs_stmt (LastStmt {}) = [] + hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs + , s <- ss] + hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + hs_stmt (XStmtLR nec) = noExtCon nec + + hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds {}) = [] + hs_local_binds (EmptyLocalBinds _) = [] + hs_local_binds (XHsLocalBindsLR _) = [] + +hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])] +hsValBindsImplicits (XValBindsLR (NValBinds binds _)) + = concatMap (lhsBindsImplicits . snd) binds +hsValBindsImplicits (ValBinds _ binds _) + = lhsBindsImplicits binds + +lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])] +lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) [] + where + lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat + lhs_bind _ = [] + +lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])] +lPatImplicits = hs_lpat + where + hs_lpat lpat = hs_pat (unLoc lpat) + + hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) [] + + hs_pat (LazyPat _ pat) = hs_lpat pat + hs_pat (BangPat _ pat) = hs_lpat pat + hs_pat (AsPat _ _ pat) = hs_lpat pat + hs_pat (ViewPat _ _ pat) = hs_lpat pat + hs_pat (ParPat _ pat) = hs_lpat pat + hs_pat (ListPat _ pats) = hs_lpats pats + hs_pat (TuplePat _ pats _) = hs_lpats pats + + hs_pat (SigPat _ pat _) = hs_lpat pat + hs_pat (CoPat _ _ pat _) = hs_pat pat + + hs_pat (ConPatIn n ps) = details n ps + hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps + + hs_pat _ = [] + + details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] + details _ (PrefixCon ps) = hs_lpats ps + details n (RecCon fs) = + [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] + ++ hs_lpats explicit_pats + + where implicit_pats = map (hsRecFieldArg . unLoc) implicit + explicit_pats = map (hsRecFieldArg . unLoc) explicit + + + (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld + | (i, fld) <- [0..] `zip` rec_flds fs + , let pat_explicit = + maybe True ((i<) . unLoc) + (rec_dotdot fs)] + err_loc = maybe (getLoc n) getLoc (rec_dotdot fs) + + details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs new file mode 100644 index 0000000000..ca38d07ddc --- /dev/null +++ b/compiler/GHC/ThToHs.hs @@ -0,0 +1,2015 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +This module converts Template Haskell syntax into Hs syntax +-} + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.ThToHs + ( convertToHsExpr + , convertToPat + , convertToHsDecls + , convertToHsType + , thRdrNameGuesses + ) +where + +import GhcPrelude + +import GHC.Hs as Hs +import PrelNames +import RdrName +import qualified Name +import Module +import RdrHsSyn +import OccName +import SrcLoc +import Type +import qualified Coercion ( Role(..) ) +import TysWiredIn +import BasicTypes as Hs +import ForeignCall +import Unique +import ErrUtils +import Bag +import Lexeme +import Util +import FastString +import Outputable +import MonadUtils ( foldrM ) + +import qualified Data.ByteString as BS +import Control.Monad( unless, ap ) + +import Data.Maybe( catMaybes, isNothing ) +import Language.Haskell.TH as TH hiding (sigP) +import Language.Haskell.TH.Syntax as TH +import Foreign.ForeignPtr +import Foreign.Ptr +import System.IO.Unsafe + +------------------------------------------------------------------- +-- The external interface + +convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] +convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds)) + where + cvt_dec d = wrapMsg "declaration" d (cvtDec d) + +convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) +convertToHsExpr loc e + = initCvt loc $ wrapMsg "expression" e $ cvtl e + +convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) +convertToPat loc p + = initCvt loc $ wrapMsg "pattern" p $ cvtPat p + +convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) +convertToHsType loc t + = initCvt loc $ wrapMsg "type" t $ cvtType t + +------------------------------------------------------------------- +newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } + deriving (Functor) + -- Push down the source location; + -- Can fail, with a single error message + +-- NB: If the conversion succeeds with (Right x), there should +-- be no exception values hiding in x +-- Reason: so a (head []) in TH code doesn't subsequently +-- make GHC crash when it tries to walk the generated tree + +-- Use the loc everywhere, for lack of anything better +-- In particular, we want it on binding locations, so that variables bound in +-- the spliced-in declarations get a location that at least relates to the splice point + +instance Applicative CvtM where + pure x = CvtM $ \loc -> Right (loc,x) + (<*>) = ap + +instance Monad CvtM where + (CvtM m) >>= k = CvtM $ \loc -> case m loc of + Left err -> Left err + Right (loc',v) -> unCvtM (k v) loc' + +initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a +initCvt loc (CvtM m) = fmap snd (m loc) + +force :: a -> CvtM () +force a = a `seq` return () + +failWith :: MsgDoc -> CvtM a +failWith m = CvtM (\_ -> Left m) + +getL :: CvtM SrcSpan +getL = CvtM (\loc -> Right (loc,loc)) + +setL :: SrcSpan -> CvtM () +setL loc = CvtM (\_ -> Right (loc, ())) + +returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a +returnL x = CvtM (\loc -> Right (loc, cL loc x)) + +returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a) +returnJustL = fmap Just . returnL + +wrapParL :: HasSrcSpan a => + (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a) +wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x))) + +wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b +-- E.g wrapMsg "declaration" dec thing +wrapMsg what item (CvtM m) + = CvtM (\loc -> case m loc of + Left err -> Left (err $$ getPprStyle msg) + Right v -> Right v) + where + -- Show the item in pretty syntax normally, + -- but with all its constructors if you say -dppr-debug + msg sty = hang (text "When splicing a TH" <+> text what <> colon) + 2 (if debugStyle sty + then text (show item) + else text (pprint item)) + +wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a +wrapL (CvtM m) = CvtM (\loc -> case m loc of + Left err -> Left err + Right (loc',v) -> Right (loc',cL loc v)) + +------------------------------------------------------------------- +cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] +cvtDecs = fmap catMaybes . mapM cvtDec + +cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs)) +cvtDec (TH.ValD pat body ds) + | TH.VarP s <- pat + = do { s' <- vNameL s + ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) + ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] } + + | otherwise + = do { pat' <- cvtPat pat + ; body' <- cvtGuard body + ; ds' <- cvtLocalDecs (text "a where clause") ds + ; returnJustL $ Hs.ValD noExtField $ + PatBind { pat_lhs = pat' + , pat_rhs = GRHSs noExtField body' (noLoc ds') + , pat_ext = noExtField + , pat_ticks = ([],[]) } } + +cvtDec (TH.FunD nm cls) + | null cls + = failWith (text "Function binding for" + <+> quotes (text (TH.pprint nm)) + <+> text "has no equations") + | otherwise + = do { nm' <- vNameL nm + ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls + ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' } + +cvtDec (TH.SigD nm typ) + = do { nm' <- vNameL nm + ; ty' <- cvtType typ + ; returnJustL $ Hs.SigD noExtField + (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) } + +cvtDec (TH.InfixD fx nm) + -- Fixity signatures are allowed for variables, constructors, and types + -- the renamer automatically looks for types during renaming, even when + -- the RdrName says it's a variable or a constructor. So, just assume + -- it's a variable or constructor and proceed. + = do { nm' <- vcNameL nm + ; returnJustL (Hs.SigD noExtField (FixSig noExtField + (FixitySig noExtField [nm'] (cvtFixity fx)))) } + +cvtDec (PragmaD prag) + = cvtPragmaD prag + +cvtDec (TySynD tc tvs rhs) + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs + ; rhs' <- cvtType rhs + ; returnJustL $ TyClD noExtField $ + SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdRhs = rhs' } } + +cvtDec (DataD ctxt tc tvs ksig constrs derivs) + = do { let isGadtCon (GadtC _ _ _) = True + isGadtCon (RecGadtC _ _ _) = True + isGadtCon (ForallC _ _ c) = isGadtCon c + isGadtCon _ = False + isGadtDecl = all isGadtCon constrs + isH98Decl = all (not . isGadtCon) constrs + ; unless (isGadtDecl || isH98Decl) + (failWith (text "Cannot mix GADT constructors with Haskell 98" + <+> text "constructors")) + ; unless (isNothing ksig || isGadtDecl) + (failWith (text "Kind signatures are only allowed on GADTs")) + ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; ksig' <- cvtKind `traverse` ksig + ; cons' <- mapM cvtConstr constrs + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noExtField + , dd_ND = DataType, dd_cType = Nothing + , dd_ctxt = ctxt' + , dd_kindSig = ksig' + , dd_cons = cons', dd_derivs = derivs' } + ; returnJustL $ TyClD noExtField $ + DataDecl { tcdDExt = noExtField + , tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdDataDefn = defn } } + +cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; ksig' <- cvtKind `traverse` ksig + ; con' <- cvtConstr constr + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noExtField + , dd_ND = NewType, dd_cType = Nothing + , dd_ctxt = ctxt' + , dd_kindSig = ksig' + , dd_cons = [con'] + , dd_derivs = derivs' } + ; returnJustL $ TyClD noExtField $ + DataDecl { tcdDExt = noExtField + , tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdDataDefn = defn } } + +cvtDec (ClassD ctxt cl tvs fds decs) + = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs + ; fds' <- mapM cvt_fundep fds + ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs + ; unless (null adts') + (failWith $ (text "Default data instance declarations" + <+> text "are not allowed:") + $$ (Outputable.ppr adts')) + ; returnJustL $ TyClD noExtField $ + ClassDecl { tcdCExt = noExtField + , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' + , tcdMeths = binds' + , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] } + -- no docs in TH ^^ + } + +cvtDec (InstanceD o ctxt ty decs) + = do { let doc = text "an instance declaration" + ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs + ; unless (null fams') (failWith (mkBadDecMsg doc fams')) + ; ctxt' <- cvtContext funPrec ctxt + ; (dL->L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty' + ; returnJustL $ InstD noExtField $ ClsInstD noExtField $ + ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty' + , cid_binds = binds' + , cid_sigs = Hs.mkClassOpSigs sigs' + , cid_tyfam_insts = ats', cid_datafam_insts = adts' + , cid_overlap_mode = fmap (cL loc . overlap) o } } + where + overlap pragma = + case pragma of + TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS") + TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE") + TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING") + TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT") + + + + +cvtDec (ForeignD ford) + = do { ford' <- cvtForD ford + ; returnJustL $ ForD noExtField ford' } + +cvtDec (DataFamilyD tc tvs kind) + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs + ; result <- cvtMaybeKindToFamilyResultSig kind + ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing } + +cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) + = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys + ; ksig' <- cvtKind `traverse` ksig + ; cons' <- mapM cvtConstr constrs + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noExtField + , dd_ND = DataType, dd_cType = Nothing + , dd_ctxt = ctxt' + , dd_kindSig = ksig' + , dd_cons = cons', dd_derivs = derivs' } + + ; returnJustL $ InstD noExtField $ DataFamInstD + { dfid_ext = noExtField + , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ + FamEqn { feqn_ext = noExtField + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = typats' + , feqn_rhs = defn + , feqn_fixity = Prefix } }}} + +cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) + = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys + ; ksig' <- cvtKind `traverse` ksig + ; con' <- cvtConstr constr + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noExtField + , dd_ND = NewType, dd_cType = Nothing + , dd_ctxt = ctxt' + , dd_kindSig = ksig' + , dd_cons = [con'], dd_derivs = derivs' } + ; returnJustL $ InstD noExtField $ DataFamInstD + { dfid_ext = noExtField + , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ + FamEqn { feqn_ext = noExtField + , feqn_tycon = tc' + , feqn_bndrs = bndrs' + , feqn_pats = typats' + , feqn_rhs = defn + , feqn_fixity = Prefix } }}} + +cvtDec (TySynInstD eqn) + = do { (dL->L _ eqn') <- cvtTySynEqn eqn + ; returnJustL $ InstD noExtField $ TyFamInstD + { tfid_ext = noExtField + , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } + +cvtDec (OpenTypeFamilyD head) + = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head + ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity' + } + +cvtDec (ClosedTypeFamilyD head eqns) + = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head + ; eqns' <- mapM cvtTySynEqn eqns + ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix + result' injectivity' } + +cvtDec (TH.RoleAnnotD tc roles) + = do { tc' <- tconNameL tc + ; let roles' = map (noLoc . cvtRole) roles + ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') } + +cvtDec (TH.StandaloneDerivD ds cxt ty) + = do { cxt' <- cvtContext funPrec cxt + ; ds' <- traverse cvtDerivStrategy ds + ; (dL->L loc ty') <- cvtType ty + ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty' + ; returnJustL $ DerivD noExtField $ + DerivDecl { deriv_ext =noExtField + , deriv_strategy = ds' + , deriv_type = mkLHsSigWcType inst_ty' + , deriv_overlap_mode = Nothing } } + +cvtDec (TH.DefaultSigD nm typ) + = do { nm' <- vNameL nm + ; ty' <- cvtType typ + ; returnJustL $ Hs.SigD noExtField + $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')} + +cvtDec (TH.PatSynD nm args dir pat) + = do { nm' <- cNameL nm + ; args' <- cvtArgs args + ; dir' <- cvtDir nm' dir + ; pat' <- cvtPat pat + ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $ + PSB noExtField nm' args' pat' dir' } + where + cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args + cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2 + cvtArgs (TH.RecordPatSyn sels) + = do { sels' <- mapM vNameL sels + ; vars' <- mapM (vNameL . mkNameS . nameBase) sels + ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } + + cvtDir _ Unidir = return Unidirectional + cvtDir _ ImplBidir = return ImplicitBidirectional + cvtDir n (ExplBidir cls) = + do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls + ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } + +cvtDec (TH.PatSynSigD nm ty) + = do { nm' <- cNameL nm + ; ty' <- cvtPatSynSigTy ty + ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')} + +-- Implicit parameter bindings are handled in cvtLocalDecs and +-- cvtImplicitParamBind. They are not allowed in any other scope, so +-- reaching this case indicates an error. +cvtDec (TH.ImplicitParamBindD _ _) + = failWith (text "Implicit parameter binding only allowed in let or where") + +---------------- +cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) +cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) + = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs + ; (head_ty, args) <- split_ty_app lhs + ; case head_ty of + ConT nm -> do { nm' <- tconNameL nm + ; rhs' <- cvtType rhs + ; let args' = map wrap_tyarg args + ; returnL $ mkHsImplicitBndrs + $ FamEqn { feqn_ext = noExtField + , feqn_tycon = nm' + , feqn_bndrs = mb_bndrs' + , feqn_pats = args' + , feqn_fixity = Prefix + , feqn_rhs = rhs' } } + InfixT t1 nm t2 -> do { nm' <- tconNameL nm + ; args' <- mapM cvtType [t1,t2] + ; rhs' <- cvtType rhs + ; returnL $ mkHsImplicitBndrs + $ FamEqn { feqn_ext = noExtField + , feqn_tycon = nm' + , feqn_bndrs = mb_bndrs' + , feqn_pats = + (map HsValArg args') ++ args + , feqn_fixity = Hs.Infix + , feqn_rhs = rhs' } } + _ -> failWith $ text "Invalid type family instance LHS:" + <+> text (show lhs) + } + +---------------- +cvt_ci_decs :: MsgDoc -> [TH.Dec] + -> CvtM (LHsBinds GhcPs, + [LSig GhcPs], + [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], + [LDataFamInstDecl GhcPs]) +-- Convert the declarations inside a class or instance decl +-- ie signatures, bindings, and associated types +cvt_ci_decs doc decs + = do { decs' <- cvtDecs decs + ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs' + ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs' + ; let (sigs', prob_binds') = partitionWith is_sig no_ats' + ; let (binds', prob_fams') = partitionWith is_bind prob_binds' + ; let (fams', bads) = partitionWith is_fam_decl prob_fams' + ; unless (null bads) (failWith (mkBadDecMsg doc bads)) + --We use FromSource as the origin of the bind + -- because the TH declaration is user-written + ; return (listToBag binds', sigs', fams', ats', adts') } + +---------------- +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] + -> CvtM ( LHsContext GhcPs + , Located RdrName + , LHsQTyVars GhcPs) +cvt_tycl_hdr cxt tc tvs + = do { cxt' <- cvtContext funPrec cxt + ; tc' <- tconNameL tc + ; tvs' <- cvtTvs tvs + ; return (cxt', tc', tvs') + } + +cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type + -> CvtM ( LHsContext GhcPs + , Located RdrName + , Maybe [LHsTyVarBndr GhcPs] + , HsTyPats GhcPs) +cvt_datainst_hdr cxt bndrs tys + = do { cxt' <- cvtContext funPrec cxt + ; bndrs' <- traverse (mapM cvt_tv) bndrs + ; (head_ty, args) <- split_ty_app tys + ; case head_ty of + ConT nm -> do { nm' <- tconNameL nm + ; let args' = map wrap_tyarg args + ; return (cxt', nm', bndrs', args') } + InfixT t1 nm t2 -> do { nm' <- tconNameL nm + ; args' <- mapM cvtType [t1,t2] + ; return (cxt', nm', bndrs', + ((map HsValArg args') ++ args)) } + _ -> failWith $ text "Invalid type instance header:" + <+> text (show tys) } + +---------------- +cvt_tyfam_head :: TypeFamilyHead + -> CvtM ( Located RdrName + , LHsQTyVars GhcPs + , Hs.LFamilyResultSig GhcPs + , Maybe (Hs.LInjectivityAnn GhcPs)) + +cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) + = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars + ; result' <- cvtFamilyResultSig result + ; injectivity' <- traverse cvtInjectivityAnnotation injectivity + ; return (tc', tyvars', result', injectivity') } + +------------------------------------------------------------------- +-- Partitioning declarations +------------------------------------------------------------------- + +is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) +is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d) +is_fam_decl decl = Right decl + +is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) +is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) + = Left (cL loc d) +is_tyfam_inst decl + = Right decl + +is_datafam_inst :: LHsDecl GhcPs + -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) +is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) + = Left (cL loc d) +is_datafam_inst decl + = Right decl + +is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) +is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig) +is_sig decl = Right decl + +is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) +is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind) +is_bind decl = Right decl + +is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec +is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) +is_ip_bind decl = Right decl + +mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc +mkBadDecMsg doc bads + = sep [ text "Illegal declaration(s) in" <+> doc <> colon + , nest 2 (vcat (map Outputable.ppr bads)) ] + +--------------------------------------------------- +-- Data types +--------------------------------------------------- + +cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) + +cvtConstr (NormalC c strtys) + = do { c' <- cNameL c + ; tys' <- mapM cvt_arg strtys + ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') } + +cvtConstr (RecC c varstrtys) + = do { c' <- cNameL c + ; args' <- mapM cvt_id_arg varstrtys + ; returnL $ mkConDeclH98 c' Nothing Nothing + (RecCon (noLoc args')) } + +cvtConstr (InfixC st1 c st2) + = do { c' <- cNameL c + ; st1' <- cvt_arg st1 + ; st2' <- cvt_arg st2 + ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') } + +cvtConstr (ForallC tvs ctxt con) + = do { tvs' <- cvtTvs tvs + ; ctxt' <- cvtContext funPrec ctxt + ; (dL->L _ con') <- cvtConstr con + ; returnL $ add_forall tvs' ctxt' con' } + where + add_cxt lcxt Nothing = Just lcxt + add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2)) + = Just (cL loc (cxt1 ++ cxt2)) + + add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) + = con { con_forall = noLoc $ not (null all_tvs) + , con_qvars = mkHsQTvs all_tvs + , con_mb_cxt = add_cxt cxt' cxt } + where + all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars + + add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) + = con { con_forall = noLoc $ not (null all_tvs) + , con_ex_tvs = all_tvs + , con_mb_cxt = add_cxt cxt' cxt } + where + all_tvs = hsQTvExplicit tvs' ++ ex_tvs + + add_forall _ _ (XConDecl nec) = noExtCon nec + +cvtConstr (GadtC c strtys ty) + = do { c' <- mapM cNameL c + ; args <- mapM cvt_arg strtys + ; (dL->L _ ty') <- cvtType ty + ; c_ty <- mk_arr_apps args ty' + ; returnL $ fst $ mkGadtDecl c' c_ty} + +cvtConstr (RecGadtC c varstrtys ty) + = do { c' <- mapM cNameL c + ; ty' <- cvtType ty + ; rec_flds <- mapM cvt_id_arg varstrtys + ; let rec_ty = noLoc (HsFunTy noExtField + (noLoc $ HsRecTy noExtField rec_flds) ty') + ; returnL $ fst $ mkGadtDecl c' rec_ty } + +cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness +cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack +cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack +cvtSrcUnpackedness SourceUnpack = SrcUnpack + +cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness +cvtSrcStrictness NoSourceStrictness = NoSrcStrict +cvtSrcStrictness SourceLazy = SrcLazy +cvtSrcStrictness SourceStrict = SrcStrict + +cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs) +cvt_arg (Bang su ss, ty) + = do { ty'' <- cvtType ty + ; let ty' = parenthesizeHsType appPrec ty'' + su' = cvtSrcUnpackedness su + ss' = cvtSrcStrictness ss + ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' } + +cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) +cvt_id_arg (i, str, ty) + = do { (dL->L li i') <- vNameL i + ; ty' <- cvt_arg (str,ty) + ; return $ noLoc (ConDeclField + { cd_fld_ext = noExtField + , cd_fld_names + = [cL li $ FieldOcc noExtField (cL li i')] + , cd_fld_type = ty' + , cd_fld_doc = Nothing}) } + +cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) +cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs + ; returnL cs' } + +cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs) +cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs + ; ys' <- mapM tNameL ys + ; returnL (xs', ys') } + + +------------------------------------------ +-- Foreign declarations +------------------------------------------ + +cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) +cvtForD (ImportF callconv safety from nm ty) + -- the prim and javascript calling conventions do not support headers + -- and are inserted verbatim, analogous to mkImport in RdrHsSyn + | callconv == TH.Prim || callconv == TH.JavaScript + = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing + (CFunction (StaticTarget (SourceText from) + (mkFastString from) Nothing + True)) + (noLoc $ quotedSourceText from)) + | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') + (mkFastString (TH.nameBase nm)) + from (noLoc $ quotedSourceText from) + = mk_imp impspec + | otherwise + = failWith $ text (show from) <+> text "is not a valid ccall impent" + where + mk_imp impspec + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; return (ForeignImport { fd_i_ext = noExtField + , fd_name = nm' + , fd_sig_ty = mkLHsSigType ty' + , fd_fi = impspec }) + } + safety' = case safety of + Unsafe -> PlayRisky + Safe -> PlaySafe + Interruptible -> PlayInterruptible + +cvtForD (ExportF callconv as nm ty) + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; let e = CExport (noLoc (CExportStatic (SourceText as) + (mkFastString as) + (cvt_conv callconv))) + (noLoc (SourceText as)) + ; return $ ForeignExport { fd_e_ext = noExtField + , fd_name = nm' + , fd_sig_ty = mkLHsSigType ty' + , fd_fe = e } } + +cvt_conv :: TH.Callconv -> CCallConv +cvt_conv TH.CCall = CCallConv +cvt_conv TH.StdCall = StdCallConv +cvt_conv TH.CApi = CApiConv +cvt_conv TH.Prim = PrimCallConv +cvt_conv TH.JavaScript = JavaScriptCallConv + +------------------------------------------ +-- Pragmas +------------------------------------------ + +cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) +cvtPragmaD (InlineP nm inline rm phases) + = do { nm' <- vNameL nm + ; let dflt = dfltActivation inline + ; let src TH.NoInline = "{-# NOINLINE" + src TH.Inline = "{-# INLINE" + src TH.Inlinable = "{-# INLINABLE" + ; let ip = InlinePragma { inl_src = SourceText $ src inline + , inl_inline = cvtInline inline + , inl_rule = cvtRuleMatch rm + , inl_act = cvtPhases phases dflt + , inl_sat = Nothing } + ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip } + +cvtPragmaD (SpecialiseP nm ty inline phases) + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; let src TH.NoInline = "{-# SPECIALISE NOINLINE" + src TH.Inline = "{-# SPECIALISE INLINE" + src TH.Inlinable = "{-# SPECIALISE INLINE" + ; let (inline', dflt,srcText) = case inline of + Just inline1 -> (cvtInline inline1, dfltActivation inline1, + src inline1) + Nothing -> (NoUserInline, AlwaysActive, + "{-# SPECIALISE") + ; let ip = InlinePragma { inl_src = SourceText srcText + , inl_inline = inline' + , inl_rule = Hs.FunLike + , inl_act = cvtPhases phases dflt + , inl_sat = Nothing } + ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip } + +cvtPragmaD (SpecialiseInstP ty) + = do { ty' <- cvtType ty + ; returnJustL $ Hs.SigD noExtField $ + SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } + +cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) + = do { let nm' = mkFastString nm + ; let act = cvtPhases phases AlwaysActive + ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs + ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs + ; lhs' <- cvtl lhs + ; rhs' <- cvtl rhs + ; returnJustL $ Hs.RuleD noExtField + $ HsRules { rds_ext = noExtField + , rds_src = SourceText "{-# RULES" + , rds_rules = [noLoc $ + HsRule { rd_ext = noExtField + , rd_name = (noLoc (quotedSourceText nm,nm')) + , rd_act = act + , rd_tyvs = ty_bndrs' + , rd_tmvs = tm_bndrs' + , rd_lhs = lhs' + , rd_rhs = rhs' }] } + + } + +cvtPragmaD (AnnP target exp) + = do { exp' <- cvtl exp + ; target' <- case target of + ModuleAnnotation -> return ModuleAnnProvenance + TypeAnnotation n -> do + n' <- tconName n + return (TypeAnnProvenance (noLoc n')) + ValueAnnotation n -> do + n' <- vcName n + return (ValueAnnProvenance (noLoc n')) + ; returnJustL $ Hs.AnnD noExtField + $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp' + } + +cvtPragmaD (LineP line file) + = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1)) + ; return Nothing + } +cvtPragmaD (CompleteP cls mty) + = do { cls' <- noLoc <$> mapM cNameL cls + ; mty' <- traverse tconNameL mty + ; returnJustL $ Hs.SigD noExtField + $ CompleteMatchSig noExtField NoSourceText cls' mty' } + +dfltActivation :: TH.Inline -> Activation +dfltActivation TH.NoInline = NeverActive +dfltActivation _ = AlwaysActive + +cvtInline :: TH.Inline -> Hs.InlineSpec +cvtInline TH.NoInline = Hs.NoInline +cvtInline TH.Inline = Hs.Inline +cvtInline TH.Inlinable = Hs.Inlinable + +cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo +cvtRuleMatch TH.ConLike = Hs.ConLike +cvtRuleMatch TH.FunLike = Hs.FunLike + +cvtPhases :: TH.Phases -> Activation -> Activation +cvtPhases AllPhases dflt = dflt +cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i +cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i + +cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) +cvtRuleBndr (RuleVar n) + = do { n' <- vNameL n + ; return $ noLoc $ Hs.RuleBndr noExtField n' } +cvtRuleBndr (TypedRuleVar n ty) + = do { n' <- vNameL n + ; ty' <- cvtType ty + ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' } + +--------------------------------------------------- +-- Declarations +--------------------------------------------------- + +cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) +cvtLocalDecs doc ds + = case partitionWith is_ip_bind ds of + ([], []) -> return (EmptyLocalBinds noExtField) + ([], _) -> do + ds' <- cvtDecs ds + let (binds, prob_sigs) = partitionWith is_bind ds' + let (sigs, bads) = partitionWith is_sig prob_sigs + unless (null bads) (failWith (mkBadDecMsg doc bads)) + return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs)) + (ip_binds, []) -> do + binds <- mapM (uncurry cvtImplicitParamBind) ip_binds + return (HsIPBinds noExtField (IPBinds noExtField binds)) + ((_:_), (_:_)) -> + failWith (text "Implicit parameters mixed with other bindings") + +cvtClause :: HsMatchContext RdrName + -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) +cvtClause ctxt (Clause ps body wheres) + = do { ps' <- cvtPats ps + ; let pps = map (parenthesizePat appPrec) ps' + ; g' <- cvtGuard body + ; ds' <- cvtLocalDecs (text "a where clause") wheres + ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) } + +cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) +cvtImplicitParamBind n e = do + n' <- wrapL (ipName n) + e' <- cvtl e + returnL (IPBind noExtField (Left n') e') + +------------------------------------------------------------------- +-- Expressions +------------------------------------------------------------------- + +cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) +cvtl e = wrapL (cvt e) + where + cvt (VarE s) = do { s' <- vName s; return $ HsVar noExtField (noLoc s') } + cvt (ConE s) = do { s' <- cName s; return $ HsVar noExtField (noLoc s') } + cvt (LitE l) + | overloadedLit l = go cvtOverLit (HsOverLit noExtField) + (hsOverLitNeedsParens appPrec) + | otherwise = go cvtLit (HsLit noExtField) + (hsLitNeedsParens appPrec) + where + go :: (Lit -> CvtM (l GhcPs)) + -> (l GhcPs -> HsExpr GhcPs) + -> (l GhcPs -> Bool) + -> CvtM (HsExpr GhcPs) + go cvt_lit mk_expr is_compound_lit = do + l' <- cvt_lit l + let e' = mk_expr l' + return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e' + cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y + ; return $ HsApp noExtField (mkLHsPar x') + (mkLHsPar y')} + cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y + ; return $ HsApp noExtField (mkLHsPar x') + (mkLHsPar y')} + cvt (AppTypeE e t) = do { e' <- cvtl e + ; t' <- cvtType t + ; let tp = parenthesizeHsType appPrec t' + ; return $ HsAppType noExtField e' + $ mkHsWildCardBndrs tp } + cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its + -- own expression to avoid pretty-printing + -- oddities that can result from zero-argument + -- lambda expressions. See #13856. + cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e + ; let pats = map (parenthesizePat appPrec) ps' + ; return $ HsLam noExtField (mkMatchGroup FromSource + [mkSimpleMatch LambdaExpr + pats e'])} + cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms + ; return $ HsLamCase noExtField + (mkMatchGroup FromSource ms') + } + cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExtField e' } + -- Note [Dropping constructors] + -- Singleton tuples treated like nothing (just parens) + cvt (TupE es) = cvt_tup es Boxed + cvt (UnboxedTupE es) = cvt_tup es Unboxed + cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e + ; unboxedSumChecks alt arity + ; return $ ExplicitSum noExtField + alt arity e'} + cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; + ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' } + cvt (MultiIfE alts) + | null alts = failWith (text "Multi-way if-expression with no alternatives") + | otherwise = do { alts' <- mapM cvtpair alts + ; return $ HsMultiIf noExtField alts' } + cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds + ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'} + cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms + ; return $ HsCase noExtField e' + (mkMatchGroup FromSource ms') } + cvt (DoE ss) = cvtHsDo DoExpr ss + cvt (MDoE ss) = cvtHsDo MDoExpr ss + cvt (CompE ss) = cvtHsDo ListComp ss + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd + ; return $ ArithSeq noExtField Nothing dd' } + cvt (ListE xs) + | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) + ; return (HsLit noExtField l') } + -- Note [Converting strings] + | otherwise = do { xs' <- mapM cvtl xs + ; return $ ExplicitList noExtField Nothing xs' + } + + -- Infix expressions + cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $ + do { x' <- cvtl x + ; s' <- cvtl s + ; y' <- cvtl y + ; let px = parenthesizeHsExpr opPrec x' + py = parenthesizeHsExpr opPrec y' + ; wrapParL (HsPar noExtField) + $ OpApp noExtField px s' py } + -- Parenthesise both arguments and result, + -- to ensure this operator application does + -- does not get re-associated + -- See Note [Operator association] + cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $ + do { s' <- cvtl s; y' <- cvtl y + ; wrapParL (HsPar noExtField) $ + SectionR noExtField s' y' } + -- See Note [Sections in HsSyn] in GHC.Hs.Expr + cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $ + do { x' <- cvtl x; s' <- cvtl s + ; wrapParL (HsPar noExtField) $ + SectionL noExtField x' s' } + + cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $ + do { s' <- cvtl s + ; return $ HsPar noExtField s' } + -- Can I indicate this is an infix thing? + -- Note [Dropping constructors] + + cvt (UInfixE x s y) = ensureValidOpExp s $ + do { x' <- cvtl x + ; let x'' = case unLoc x' of + OpApp {} -> x' + _ -> mkLHsPar x' + ; cvtOpApp x'' s y } -- Note [Converting UInfix] + + cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExtField e' } + cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t + ; let pe = parenthesizeHsExpr sigPrec e' + ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') } + cvt (RecConE c flds) = do { c' <- cNameL c + ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds + ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } + cvt (RecUpdE e flds) = do { e' <- cvtl e + ; flds' + <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) + flds + ; return $ mkRdrRecordUpd e' flds' } + cvt (StaticE e) = fmap (HsStatic noExtField) $ cvtl e + cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is + -- important, because UnboundVarE may contain + -- constructor names - see #14627. + { s' <- vcName s + ; return $ HsVar noExtField (noLoc s') } + cvt (LabelE s) = do { return $ HsOverLabel noExtField Nothing (fsLit s) } + cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } + +{- | #16895 Ensure an infix expression's operator is a variable/constructor. +Consider this example: + + $(uInfixE [|1|] [|id id|] [|2|]) + +This infix expression is obviously ill-formed so we use this helper function +to reject such programs outright. + +The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp` +in Language.Haskell.TH.Ppr from the template-haskell library. +-} +ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a +ensureValidOpExp (VarE _n) m = m +ensureValidOpExp (ConE _n) m = m +ensureValidOpExp (UnboundVarE _n) m = m +ensureValidOpExp _e _m = + failWith (text "Non-variable expression is not allowed in an infix expression") + +{- Note [Dropping constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we drop constructors from the input (for instance, when we encounter @TupE [e]@) +we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@ +could meet @UInfix@ constructors containing the @TupE [e]@. For example: + + UInfixE x * (TupE [UInfixE y + z]) + +If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet +and the above expression would be reassociated to + + OpApp (OpApp x * y) + z + +which we don't want. +-} + +cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) + -> CvtM (LHsRecField' t (LHsExpr GhcPs)) +cvtFld f (v,e) + = do { v' <- vNameL v; e' <- cvtl e + ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v' + , hsRecFieldArg = e' + , hsRecPun = False}) } + +cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) +cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } +cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } +cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } +cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } + +cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs) +cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg + cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e) + ; es' <- mapM cvtl_maybe es + ; return $ ExplicitTuple + noExtField + (map noLoc es') + boxity } + +{- Note [Operator assocation] +We must be quite careful about adding parens: + * Infix (UInfix ...) op arg Needs parens round the first arg + * Infix (Infix ...) op arg Needs parens round the first arg + * UInfix (UInfix ...) op arg No parens for first arg + * UInfix (Infix ...) op arg Needs parens round first arg + + +Note [Converting UInfix] +~~~~~~~~~~~~~~~~~~~~~~~~ +When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust +the trees to reflect the fixities of the underlying operators: + + UInfixE x * (UInfixE y + z) ---> (x * y) + z + +This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and +@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely +right-biased for types and left-biased for everything else. So we left-bias the +trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. + +Sample input: + + UInfixE + (UInfixE x op1 y) + op2 + (UInfixE z op3 w) + +Sample output: + + OpApp + (OpApp + (OpApp x op1 y) + op2 + z) + op3 + w + +The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this +biasing. +-} + +{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix expressions will be left-biased, provided @x@ is. + +We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis +is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that +this holds for both branches (of @cvtOpApp@), provided we assume it holds for +the recursive calls to @cvtOpApp@. + +When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased +since we have already run @cvtl@ on it. +-} +cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs) +cvtOpApp x op1 (UInfixE y op2 z) + = do { l <- wrapL $ cvtOpApp x op1 y + ; cvtOpApp l op2 z } +cvtOpApp x op y + = do { op' <- cvtl op + ; y' <- cvtl y + ; return (OpApp noExtField x op' y') } + +------------------------------------- +-- Do notation and statements +------------------------------------- + +cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs) +cvtHsDo do_or_lc stmts + | null stmts = failWith (text "Empty stmt list in do-block") + | otherwise + = do { stmts' <- cvtStmts stmts + ; let Just (stmts'', last') = snocView stmts' + + ; last'' <- case last' of + (dL->L loc (BodyStmt _ body _ _)) + -> return (cL loc (mkLastStmt body)) + _ -> failWith (bad_last last') + + ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) } + where + bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon + , nest 2 $ Outputable.ppr stmt + , text "(It should be an expression.)" ] + +cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] +cvtStmts = mapM cvtStmt + +cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) +cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } +cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } +cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds + ; returnL $ LetStmt noExtField (noLoc ds') } +cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss + ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr } + where + cvt_one ds = do { ds' <- cvtStmts ds + ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } +cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') } + +cvtMatch :: HsMatchContext RdrName + -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) +cvtMatch ctxt (TH.Match p body decs) + = do { p' <- cvtPat p + ; let lp = case p' of + (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875 + _ -> p' + ; g' <- cvtGuard body + ; decs' <- cvtLocalDecs (text "a where clause") decs + ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) } + +cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] +cvtGuard (GuardedB pairs) = mapM cvtpair pairs +cvtGuard (NormalB e) = do { e' <- cvtl e + ; g' <- returnL $ GRHS noExtField [] e'; return [g'] } + +cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) +cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs + ; g' <- returnL $ mkBodyStmt ge' + ; returnL $ GRHS noExtField [g'] rhs' } +cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs + ; returnL $ GRHS noExtField gs' rhs' } + +cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) +cvtOverLit (IntegerL i) + = do { force i; return $ mkHsIntegral (mkIntegralLit i) } +cvtOverLit (RationalL r) + = do { force r; return $ mkHsFractional (mkFractionalLit r) } +cvtOverLit (StringL s) + = do { let { s' = mkFastString s } + ; force s' + ; return $ mkHsIsString (quotedSourceText s) s' + } +cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" +-- An Integer is like an (overloaded) '3' in a Haskell source program +-- Similarly 3.5 for fractionals + +{- Note [Converting strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to +a string literal for "xy". Of course, we might hope to get +(LitE (StringL "xy")), but not always, and allCharLs fails quickly +if it isn't a literal string +-} + +allCharLs :: [TH.Exp] -> Maybe String +-- Note [Converting strings] +-- NB: only fire up this setup for a non-empty list, else +-- there's a danger of returning "" for [] :: [Int]! +allCharLs xs + = case xs of + LitE (CharL c) : ys -> go [c] ys + _ -> Nothing + where + go cs [] = Just (reverse cs) + go cs (LitE (CharL c) : ys) = go (c:cs) ys + go _ _ = Nothing + +cvtLit :: Lit -> CvtM (HsLit GhcPs) +cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } +cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } +cvtLit (FloatPrimL f) + = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) } +cvtLit (DoublePrimL f) + = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) } +cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } +cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } +cvtLit (StringL s) = do { let { s' = mkFastString s } + ; force s' + ; return $ HsString (quotedSourceText s) s' } +cvtLit (StringPrimL s) = do { let { s' = BS.pack s } + ; force s' + ; return $ HsStringPrim NoSourceText s' } +cvtLit (BytesPrimL (Bytes fptr off sz)) = do + let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr -> + BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz) + force bs + return $ HsStringPrim NoSourceText bs +cvtLit _ = panic "Convert.cvtLit: Unexpected literal" + -- cvtLit should not be called on IntegerL, RationalL + -- That precondition is established right here in + -- Convert.hs, hence panic + +quotedSourceText :: String -> SourceText +quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" + +cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] +cvtPats pats = mapM cvtPat pats + +cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs) +cvtPat pat = wrapL (cvtp pat) + +cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) +cvtp (TH.LitP l) + | overloadedLit l = do { l' <- cvtOverLit l + ; return (mkNPat (noLoc l') Nothing) } + -- Not right for negative patterns; + -- need to think about that! + | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } +cvtp (TH.VarP s) = do { s' <- vName s + ; return $ Hs.VarPat noExtField (noLoc s') } +cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExtField p' } + -- Note [Dropping constructors] +cvtp (TupP ps) = do { ps' <- cvtPats ps + ; return $ TuplePat noExtField ps' Boxed } +cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps + ; return $ TuplePat noExtField ps' Unboxed } +cvtp (UnboxedSumP p alt arity) + = do { p' <- cvtPat p + ; unboxedSumChecks alt arity + ; return $ SumPat noExtField p' alt arity } +cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps + ; let pps = map (parenthesizePat appPrec) ps' + ; return $ ConPatIn s' (PrefixCon pps) } +cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 + ; wrapParL (ParPat noExtField) $ + ConPatIn s' $ + InfixCon (parenthesizePat opPrec p1') + (parenthesizePat opPrec p2') } + -- See Note [Operator association] +cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] +cvtp (ParensP p) = do { p' <- cvtPat p; + ; case unLoc p' of -- may be wrapped ConPatIn + ParPat {} -> return $ unLoc p' + _ -> return $ ParPat noExtField p' } +cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExtField p' } +cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExtField p' } +cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p + ; return $ AsPat noExtField s' p' } +cvtp TH.WildP = return $ WildPat noExtField +cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs + ; return $ ConPatIn c' + $ Hs.RecCon (HsRecFields fs' Nothing) } +cvtp (ListP ps) = do { ps' <- cvtPats ps + ; return + $ ListPat noExtField ps'} +cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t + ; return $ SigPat noExtField p' (mkLHsSigWcType t') } +cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p + ; return $ ViewPat noExtField e' p'} + +cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) +cvtPatFld (s,p) + = do { (dL->L ls s') <- vNameL s + ; p' <- cvtPat p + ; return (noLoc $ HsRecField { hsRecFieldLbl + = cL ls $ mkFieldOcc (cL ls s') + , hsRecFieldArg = p' + , hsRecPun = False}) } + +{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix patterns will be left-biased, provided @x@ is. + +See the @cvtOpApp@ documentation for how this function works. +-} +cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs) +cvtOpAppP x op1 (UInfixP y op2 z) + = do { l <- wrapL $ cvtOpAppP x op1 y + ; cvtOpAppP l op2 z } +cvtOpAppP x op y + = do { op' <- cNameL op + ; y' <- cvtPat y + ; return (ConPatIn op' (InfixCon x y')) } + +----------------------------------------------------------- +-- Types and type variables + +cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) +cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } + +cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) +cvt_tv (TH.PlainTV nm) + = do { nm' <- tNameL nm + ; returnL $ UserTyVar noExtField nm' } +cvt_tv (TH.KindedTV nm ki) + = do { nm' <- tNameL nm + ; ki' <- cvtKind ki + ; returnL $ KindedTyVar noExtField nm' ki' } + +cvtRole :: TH.Role -> Maybe Coercion.Role +cvtRole TH.NominalR = Just Coercion.Nominal +cvtRole TH.RepresentationalR = Just Coercion.Representational +cvtRole TH.PhantomR = Just Coercion.Phantom +cvtRole TH.InferR = Nothing + +cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs) +cvtContext p tys = do { preds' <- mapM cvtPred tys + ; parenthesizeHsContext p <$> returnL preds' } + +cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) +cvtPred = cvtType + +cvtDerivClause :: TH.DerivClause + -> CvtM (LHsDerivingClause GhcPs) +cvtDerivClause (TH.DerivClause ds ctxt) + = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt + ; ds' <- traverse cvtDerivStrategy ds + ; returnL $ HsDerivingClause noExtField ds' ctxt' } + +cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) +cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy +cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy +cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy +cvtDerivStrategy (TH.ViaStrategy ty) = do + ty' <- cvtType ty + returnL $ Hs.ViaStrategy (mkLHsSigType ty') + +cvtType :: TH.Type -> CvtM (LHsType GhcPs) +cvtType = cvtTypeKind "type" + +cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) +cvtTypeKind ty_str ty + = do { (head_ty, tys') <- split_ty_app ty + ; let m_normals = mapM extract_normal tys' + where extract_normal (HsValArg ty) = Just ty + extract_normal _ = Nothing + + ; case head_ty of + TupleT n + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> if n==1 then return (head normals) -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy noExtField + HsBoxedOrConstraintTuple normals) + | n == 1 + -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) + | otherwise + -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) + tys' + UnboxedTupleT n + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnL (HsTupleTy noExtField HsUnboxedTuple normals) + | otherwise + -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) + tys' + UnboxedSumT n + | n < 2 + -> failWith $ + vcat [ text "Illegal sum arity:" <+> text (show n) + , nest 2 $ + text "Sums must have an arity of at least 2" ] + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnL (HsSumTy noExtField normals) + | otherwise + -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n)))) + tys' + ArrowT + | Just normals <- m_normals + , [x',y'] <- normals -> do + x'' <- case unLoc x' of + HsFunTy{} -> returnL (HsParTy noExtField x') + HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646 + HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324 + _ -> return $ + parenthesizeHsType sigPrec x' + let y'' = parenthesizeHsType sigPrec y' + returnL (HsFunTy noExtField x'' y'') + | otherwise + -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon))) + tys' + ListT + | Just normals <- m_normals + , [x'] <- normals -> do + returnL (HsListTy noExtField x') + | otherwise + -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon))) + tys' + + VarT nm -> do { nm' <- tNameL nm + ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' } + ConT nm -> do { nm' <- tconName nm + ; -- ConT can contain both data constructor (i.e., + -- promoted) names and other (i.e, unpromoted) + -- names, as opposed to PromotedT, which can only + -- contain data constructor names. See #15572. + let prom = if isRdrDataCon nm' + then IsPromoted + else NotPromoted + ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'} + + ForallT tvs cxt ty + | null tys' + -> do { tvs' <- cvtTvs tvs + ; cxt' <- cvtContext funPrec cxt + ; ty' <- cvtType ty + ; loc <- getL + ; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty + rho_ty = mkHsQualTy cxt loc cxt' ty' + + ; return hs_ty } + + ForallVisT tvs ty + | null tys' + -> do { tvs' <- cvtTvs tvs + ; ty' <- cvtType ty + ; loc <- getL + ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' } + + SigT ty ki + -> do { ty' <- cvtType ty + ; ki' <- cvtKind ki + ; mk_apps (HsKindSig noExtField ty' ki') tys' + } + + LitT lit + -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys' + + WildCardT + -> mk_apps mkAnonWildCardTy tys' + + InfixT t1 s t2 + -> do { s' <- tconName s + ; t1' <- cvtType t1 + ; t2' <- cvtType t2 + ; mk_apps + (HsTyVar noExtField NotPromoted (noLoc s')) + ([HsValArg t1', HsValArg t2'] ++ tys') + } + + UInfixT t1 s t2 + -> do { t2' <- cvtType t2 + ; t <- cvtOpAppT t1 s t2' + ; mk_apps (unLoc t) tys' + } -- Note [Converting UInfix] + + ParensT t + -> do { t' <- cvtType t + ; mk_apps (HsParTy noExtField t') tys' + } + + PromotedT nm -> do { nm' <- cName nm + ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm')) + tys' } + -- Promoted data constructor; hence cName + + PromotedTupleT n + | n == 1 + -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnL (HsExplicitTupleTy noExtField normals) + | otherwise + -> mk_apps + (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n)))) + tys' + + PromotedNilT + -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys' + + PromotedConsT -- See Note [Representing concrete syntax in types] + -- in Language.Haskell.TH.Syntax + | Just normals <- m_normals + , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals + -> do + returnL (HsExplicitListTy noExtField ip (ty1:tys2)) + | otherwise + -> mk_apps + (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon))) + tys' + + StarT + -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) + tys' + + ConstraintT + -> mk_apps + (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon))) + tys' + + EqualityT + | Just normals <- m_normals + , [x',y'] <- normals -> + let px = parenthesizeHsType opPrec x' + py = parenthesizeHsType opPrec y' + in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py) + -- The long-term goal is to remove the above case entirely and + -- subsume it under the case for InfixT. See #15815, comment:6, + -- for more details. + + | otherwise -> + mk_apps (HsTyVar noExtField NotPromoted + (noLoc eqTyCon_RDR)) tys' + ImplicitParamT n t + -> do { n' <- wrapL $ ipName n + ; t' <- cvtType t + ; returnL (HsIParamTy noExtField n' t') + } + + _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) + } + +-- | Constructs an application of a type to arguments passed in a list. +mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) +mk_apps head_ty type_args = do + head_ty' <- returnL head_ty + -- We must parenthesize the function type in case of an explicit + -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there + -- _must_ be parentheses around `Maybe :: Type -> Type`. + let phead_ty :: LHsType GhcPs + phead_ty = parenthesizeHsType sigPrec head_ty' + + go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) + go [] = pure head_ty' + go (arg:args) = + case arg of + HsValArg ty -> do p_ty <- add_parens ty + mk_apps (HsAppTy noExtField phead_ty p_ty) args + HsTypeArg l ki -> do p_ki <- add_parens ki + mk_apps (HsAppKindTy l phead_ty p_ki) args + HsArgPar _ -> mk_apps (HsParTy noExtField phead_ty) args + + go type_args + where + -- See Note [Adding parens for splices] + add_parens lt@(dL->L _ t) + | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) + | otherwise = return lt + +wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs +wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty +wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki +wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized + +-- --------------------------------------------------------------------- +-- Note [Adding parens for splices] +{- +The hsSyn representation of parsed source explicitly contains all the original +parens, as written in the source. + +When a Template Haskell (TH) splice is evaluated, the original splice is first +renamed and type checked and then finally converted to core in DsMeta. This core +is then run in the TH engine, and the result comes back as a TH AST. + +In the process, all parens are stripped out, as they are not needed. + +This Convert module then converts the TH AST back to hsSyn AST. + +In order to pretty-print this hsSyn AST, parens need to be adde back at certain +points so that the code is readable with its original meaning. + +So scattered through Convert.hs are various points where parens are added. + +See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289 +-} +-- --------------------------------------------------------------------- + +-- | Constructs an arrow type with a specified return type +mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) +mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL + where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) + go arg ret_ty = do { ret_ty_l <- returnL ret_ty + ; return (HsFunTy noExtField arg ret_ty_l) } + +split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) +split_ty_app ty = go ty [] + where + go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') } + go (AppKindT ty ki) as' = do { ki' <- cvtKind ki + ; go ty (HsTypeArg noSrcSpan ki':as') } + go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } + go f as = return (f,as) + +cvtTyLit :: TH.TyLit -> HsTyLit +cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i +cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) + +{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator +application @x `op` y@. The produced tree of infix types will be right-biased, +provided @y@ is. + +See the @cvtOpApp@ documentation for how this function works. +-} +cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs) +cvtOpAppT (UInfixT x op2 y) op1 z + = do { l <- cvtOpAppT y op1 z + ; cvtOpAppT x op2 l } +cvtOpAppT x op y + = do { op' <- tconNameL op + ; x' <- cvtType x + ; returnL (mkHsOpTy x' op' y) } + +cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) +cvtKind = cvtTypeKind "kind" + +-- | Convert Maybe Kind to a type family result signature. Used with data +-- families where naming of the result is not possible (thus only kind or no +-- signature is possible). +cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind + -> CvtM (LFamilyResultSig GhcPs) +cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExtField) +cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki + ; returnL (Hs.KindSig noExtField ki') } + +-- | Convert type family result signature. Used with both open and closed type +-- families. +cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs) +cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExtField) +cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki + ; returnL (Hs.KindSig noExtField ki') } +cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr + ; returnL (Hs.TyVarSig noExtField tv) } + +-- | Convert injectivity annotation of a type family. +cvtInjectivityAnnotation :: TH.InjectivityAnn + -> CvtM (Hs.LInjectivityAnn GhcPs) +cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) + = do { annLHS' <- tNameL annLHS + ; annRHS' <- mapM tNameL annRHS + ; returnL (Hs.InjectivityAnn annLHS' annRHS') } + +cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs) +-- pattern synonym types are of peculiar shapes, which is why we treat +-- them separately from regular types; +-- see Note [Pattern synonym type signatures and Template Haskell] +cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) + | null exis, null provs = cvtType (ForallT univs reqs ty) + | null univs, null reqs = do { l <- getL + ; ty' <- cvtType (ForallT exis provs ty) + ; return $ cL l (HsQualTy { hst_ctxt = cL l [] + , hst_xqual = noExtField + , hst_body = ty' }) } + | null reqs = do { l <- getL + ; univs' <- hsQTvExplicit <$> cvtTvs univs + ; ty' <- cvtType (ForallT exis provs ty) + ; let forTy = HsForAllTy + { hst_fvf = ForallInvis + , hst_bndrs = univs' + , hst_xforall = noExtField + , hst_body = cL l cxtTy } + cxtTy = HsQualTy { hst_ctxt = cL l [] + , hst_xqual = noExtField + , hst_body = ty' } + ; return $ cL l forTy } + | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) +cvtPatSynSigTy ty = cvtType ty + +----------------------------------------------------------- +cvtFixity :: TH.Fixity -> Hs.Fixity +cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir) + where + cvt_dir TH.InfixL = Hs.InfixL + cvt_dir TH.InfixR = Hs.InfixR + cvt_dir TH.InfixN = Hs.InfixN + +----------------------------------------------------------- + + +----------------------------------------------------------- +-- some useful things + +overloadedLit :: Lit -> Bool +-- True for literals that Haskell treats as overloaded +overloadedLit (IntegerL _) = True +overloadedLit (RationalL _) = True +overloadedLit _ = False + +-- Checks that are performed when converting unboxed sum expressions and +-- patterns alike. +unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM () +unboxedSumChecks alt arity + | alt > arity + = failWith $ text "Sum alternative" <+> text (show alt) + <+> text "exceeds its arity," <+> text (show arity) + | alt <= 0 + = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt) + , nest 2 $ text "Sum alternatives must start from 1" ] + | arity < 2 + = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity) + , nest 2 $ text "Sums must have an arity of at least 2" ] + | otherwise + = return () + +-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the +-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' +-- using the provided 'LHsQTyVars' and 'LHsType'. +mkHsForAllTy :: [TH.TyVarBndr] + -- ^ The original Template Haskell type variable binders + -> SrcSpan + -- ^ The location of the returned 'LHsType' if it needs an + -- explicit forall + -> ForallVisFlag + -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@) + -- or invisible (e.g., @forall a.@) + -> LHsQTyVars GhcPs + -- ^ The converted type variable binders + -> LHsType GhcPs + -- ^ The converted rho type + -> LHsType GhcPs + -- ^ The complete type, quantified with a forall if necessary +mkHsForAllTy tvs loc fvf tvs' rho_ty + | null tvs = rho_ty + | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf + , hst_bndrs = hsQTvExplicit tvs' + , hst_xforall = noExtField + , hst_body = rho_ty } + +-- | If passed an empty 'TH.Cxt', this simply returns the third argument +-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided +-- 'LHsContext' and 'LHsType'. + +-- It's important that we don't build an HsQualTy if the context is empty, +-- as the pretty-printer for HsType _always_ prints contexts, even if +-- they're empty. See #13183. +mkHsQualTy :: TH.Cxt + -- ^ The original Template Haskell context + -> SrcSpan + -- ^ The location of the returned 'LHsType' if it needs an + -- explicit context + -> LHsContext GhcPs + -- ^ The converted context + -> LHsType GhcPs + -- ^ The converted tau type + -> LHsType GhcPs + -- ^ The complete type, qualified with a context if necessary +mkHsQualTy ctxt loc ctxt' ty + | null ctxt = ty + | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField + , hst_ctxt = ctxt' + , hst_body = ty } + +-------------------------------------------------------------------- +-- Turning Name back into RdrName +-------------------------------------------------------------------- + +-- variable names +vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName + +-- Variable names +vNameL n = wrapL (vName n) +vName n = cvtName OccName.varName n + +-- Constructor function names; this is Haskell source, hence srcDataName +cNameL n = wrapL (cName n) +cName n = cvtName OccName.dataName n + +-- Variable *or* constructor names; check by looking at the first char +vcNameL n = wrapL (vcName n) +vcName n = if isVarName n then vName n else cName n + +-- Type variable names +tNameL n = wrapL (tName n) +tName n = cvtName OccName.tvName n + +-- Type Constructor names +tconNameL n = wrapL (tconName n) +tconName n = cvtName OccName.tcClsName n + +ipName :: String -> CvtM HsIPName +ipName n + = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n)) + ; return (HsIPName (fsLit n)) } + +cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName +cvtName ctxt_ns (TH.Name occ flavour) + | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) + | otherwise + = do { loc <- getL + ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour + ; force rdr_name + ; return rdr_name } + where + occ_str = TH.occString occ + +okOcc :: OccName.NameSpace -> String -> Bool +okOcc ns str + | OccName.isVarNameSpace ns = okVarOcc str + | OccName.isDataConNameSpace ns = okConOcc str + | otherwise = okTcOcc str + +-- Determine the name space of a name in a type +-- +isVarName :: TH.Name -> Bool +isVarName (TH.Name occ _) + = case TH.occString occ of + "" -> False + (c:_) -> startsVarId c || startsVarSym c + +badOcc :: OccName.NameSpace -> String -> SDoc +badOcc ctxt_ns occ + = text "Illegal" <+> pprNameSpace ctxt_ns + <+> text "name:" <+> quotes (text occ) + +thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName +-- This turns a TH Name into a RdrName; used for both binders and occurrences +-- See Note [Binders in Template Haskell] +-- The passed-in name space tells what the context is expecting; +-- use it unless the TH name knows what name-space it comes +-- from, in which case use the latter +-- +-- We pass in a SrcSpan (gotten from the monad) because this function +-- is used for *binders* and if we make an Exact Name we want it +-- to have a binding site inside it. (cf #5434) +-- +-- ToDo: we may generate silly RdrNames, by passing a name space +-- that doesn't match the string, like VarName ":+", +-- which will give confusing error messages later +-- +-- The strict applications ensure that any buried exceptions get forced +thRdrName loc ctxt_ns th_occ th_name + = case th_name of + TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod + TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ + TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc) + TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc) + TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name + | otherwise -> mkRdrUnqual $! occ + -- We check for built-in syntax here, because the TH + -- user might have written a (NameS "(,,)"), for example + where + occ :: OccName.OccName + occ = mk_occ ctxt_ns th_occ + +-- Return an unqualified exact RdrName if we're dealing with built-in syntax. +-- See #13776. +thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName +thOrigRdrName occ th_ns pkg mod = + let occ' = mk_occ (mk_ghc_ns th_ns) occ + in case isBuiltInOcc_maybe occ' of + Just name -> nameRdrName name + Nothing -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ' + +thRdrNameGuesses :: TH.Name -> [RdrName] +thRdrNameGuesses (TH.Name occ flavour) + -- This special case for NameG ensures that we don't generate duplicates in the output list + | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod] + | otherwise = [ thRdrName noSrcSpan gns occ_str flavour + | gns <- guessed_nss] + where + -- guessed_ns are the name spaces guessed from looking at the TH name + guessed_nss + | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] + | otherwise = [OccName.varName, OccName.tvName] + occ_str = TH.occString occ + +-- The packing and unpacking is rather turgid :-( +mk_occ :: OccName.NameSpace -> String -> OccName.OccName +mk_occ ns occ = OccName.mkOccName ns occ + +mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace +mk_ghc_ns TH.DataName = OccName.dataName +mk_ghc_ns TH.TcClsName = OccName.tcClsName +mk_ghc_ns TH.VarName = OccName.varName + +mk_mod :: TH.ModName -> ModuleName +mk_mod mod = mkModuleName (TH.modString mod) + +mk_pkg :: TH.PkgName -> UnitId +mk_pkg pkg = stringToUnitId (TH.pkgString pkg) + +mk_uniq :: Int -> Unique +mk_uniq u = mkUniqueGrimily u + +{- +Note [Binders in Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this TH term construction: + do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name + ; x2 <- TH.newName "x" -- Builds a NameU + ; x3 <- TH.newName "x" + + ; let x = mkName "x" -- mkName :: String -> TH.Name + -- Builds a NameS + + ; return (LamE (..pattern [x1,x2]..) $ + LamE (VarPat x3) $ + ..tuple (x1,x2,x3,x)) } + +It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) + +a) We don't want to complain about "x" being bound twice in + the pattern [x1,x2] +b) We don't want x3 to shadow the x1,x2 +c) We *do* want 'x' (dynamically bound with mkName) to bind + to the innermost binding of "x", namely x3. +d) When pretty printing, we want to print a unique with x1,x2 + etc, else they'll all print as "x" which isn't very helpful + +When we convert all this to HsSyn, the TH.Names are converted with +thRdrName. To achieve (b) we want the binders to be Exact RdrNames. +Achieving (a) is a bit awkward, because + - We must check for duplicate and shadowed names on Names, + not RdrNames, *after* renaming. + See Note [Collect binders only after renaming] in GHC.Hs.Utils + + - But to achieve (a) we must distinguish between the Exact + RdrNames arising from TH and the Unqual RdrNames that would + come from a user writing \[x,x] -> blah + +So in Convert.thRdrName we translate + TH Name RdrName + -------------------------------------------------------- + NameU (arising from newName) --> Exact (Name{ System }) + NameS (arising from mkName) --> Unqual + +Notice that the NameUs generate *System* Names. Then, when +figuring out shadowing and duplicates, we can filter out +System Names. + +This use of System Names fits with other uses of System Names, eg for +temporary variables "a". Since there are lots of things called "a" we +usually want to print the name with the unique, and that is indeed +the way System Names are printed. + +There's a small complication of course; see Note [Looking up Exact +RdrNames] in RnEnv. +-} + +{- +Note [Pattern synonym type signatures and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In general, the type signature of a pattern synonym + + pattern P x1 x2 .. xn = + +is of the form + + forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t + +with the following parts: + + 1) the (possibly empty lists of) universally quantified type + variables `univs` and required constraints `reqs` on them. + 2) the (possibly empty lists of) existentially quantified type + variables `exis` and the provided constraints `provs` on them. + 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1, + x2, .., xn, respectively + 4) the type `t` of , mentioning only universals from `univs`. + +Due to the two forall quantifiers and constraint contexts (either of +which might be empty), pattern synonym type signatures are treated +specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and +`typecheck/TcSplice.hs`: + + (a) When desugaring a pattern synonym from HsSyn to TH.Dec in + `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.: + + ForallT univs reqs (ForallT exis provs ty) + (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) + + (b) When converting pattern synonyms from TH.Dec to HsSyn in + `hsSyn/Convert.hs`, we convert their TH type signatures back to an + appropriate Haskell pattern synonym type of the form + + forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t + + where initial empty `univs` type variables or an empty `reqs` + constraint context are represented *explicitly* as `() =>`. + + (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always + return its *full* type, i.e.: + + ForallT univs reqs (ForallT exis provs ty) + (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) + +The key point is to always represent a pattern synonym's *full* type +in cases (a) and (c) to make it clear which of the two forall +quantifiers and/or constraint contexts are specified, and which are +not. See GHC's user's guide on pattern synonyms for more information +about pattern synonym type signatures. + +-} diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs index 67905c6067..e17c905379 100644 --- a/compiler/backpack/BkpSyn.hs +++ b/compiler/backpack/BkpSyn.hs @@ -19,7 +19,7 @@ module BkpSyn ( import GhcPrelude -import HsSyn +import GHC.Hs import SrcLoc import Outputable import Module diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index f2d6f2b46a..43ad2cbbba 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -1211,7 +1211,7 @@ data Activation = NeverActive | ActiveAfter SourceText PhaseNum -- Active in this phase and later deriving( Eq, Data ) - -- Eq used in comparing rules in HsDecls + -- Eq used in comparing rules in GHC.Hs.Decls -- | Rule Match Information data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 16123e7b3a..f8fb9ef971 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -142,7 +142,7 @@ These data types are the heart of the compiler -- We get from Haskell source to this Core language in a number of stages: -- -- 1. The source code is parsed into an abstract syntax tree, which is represented --- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames' +-- by the data type 'GHC.Hs.Expr.HsExpr' with the names being 'RdrName.RdrNames' -- -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName' -- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. @@ -162,9 +162,9 @@ These data types are the heart of the compiler -- But see Note [Shadowing] below. -- -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating --- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names. +-- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'Id.Id' as it's names. -- --- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into +-- 4. Finally the syntax tree is /desugared/ from the expressive 'GHC.Hs.Expr.HsExpr' type into -- this 'Expr' type, which has far fewer constructors and hence is easier to perform -- optimization, analysis and code generation on. -- diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index f9609f834d..e2c881a1c4 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -64,7 +64,7 @@ import HscTypes import TysWiredIn import PrelNames -import HsUtils ( mkChunkified, chunkify ) +import GHC.Hs.Utils ( mkChunkified, chunkify ) import Type import Coercion ( isCoVar ) import TysPrim diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 1c9493bbca..4808b56eae 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -35,7 +35,7 @@ import CoreUtils (exprType) import FastString (unpackFS) import Unify( tcMatchTy ) import DynFlags -import HsSyn +import GHC.Hs import TcHsSyn import Id import ConLike @@ -1334,7 +1334,7 @@ available so we can get more precise results. For this reason we have functions term constraints (respectively) as we go deeper. The type constraints we propagate inwards are collected by `collectEvVarsPats' -in HsPat.hs. This handles bug #4139 ( see example +in GHC.Hs.Pat. This handles bug #4139 ( see example https://gitlab.haskell.org/ghc/ghc/snippets/672 ) where this is needed. diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index e587c74121..b7bed75f3d 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -18,7 +18,7 @@ import Data.Array import ByteCodeTypes import GHC.Stack.CCS import Type -import HsSyn +import GHC.Hs import Module import Outputable import DynFlags diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 2c0b4139a6..5df52c3df9 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -22,7 +22,7 @@ import GhcPrelude import DsUsage import DynFlags import HscTypes -import HsSyn +import GHC.Hs import TcRnTypes import TcRnMonad ( finalSafeMode, fixSafeInstances ) import TcRnDriver ( runTcInteractive ) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index cc12920520..ade017208d 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -20,11 +20,11 @@ import Match import DsUtils import DsMonad -import HsSyn hiding (collectPatBinders, collectPatsBinders, +import GHC.Hs hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders ) import TcHsSyn -import qualified HsUtils +import qualified GHC.Hs.Utils as HsUtils -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not @@ -62,7 +62,7 @@ data DsCmdEnv = DsCmdEnv { } mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv) --- See Note [CmdSyntaxTable] in HsExpr +-- See Note [CmdSyntaxTable] in GHC.Hs.Expr mkCmdEnv tc_meths = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths @@ -1191,10 +1191,10 @@ foldb f xs = foldb f (fold_pairs xs) fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs {- -Note [Dictionary binders in ConPatOut] See also same Note in HsUtils +Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The following functions to collect value variables from patterns are -copied from HsUtils, with one change: we also collect the dictionary +copied from GHC.Hs.Utils, with one change: we also collect the dictionary bindings (pat_binds) from ConPatOut. We need them for cases like h :: Arrow a => Int -> a (Int,Int) Int @@ -1208,7 +1208,7 @@ The type checker turns the case into Here p77 is a local binding for the (+) operation. -See comments in HsUtils for why the other version does not include +See comments in GHC.Hs.Utils for why the other version does not include these bindings. -} diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index cea7f3215b..0d4c868d76 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -31,7 +31,7 @@ import DsGRHSs import DsUtils import Check ( needToRunPmCheck, addTyCsDs, checkGuardMatches ) -import HsSyn -- lots of things +import GHC.Hs -- lots of things import CoreSyn -- lots of things import CoreOpt ( simpleOptExpr ) import OccurAnal ( occurAnalyseExpr ) @@ -618,9 +618,9 @@ We define an "unlifted bind" to be any bind that binds an unlifted id. Note that x :: Char (# True, x #) = blah -is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind. +is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. -Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind. +Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. Define a "strict bind" to be either an unlifted bind or a banged bind. The restrictions are: diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 183b1e7650..1fa2dd8b99 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -30,7 +30,7 @@ import Name import NameEnv import FamInstEnv( topNormaliseType ) import DsMeta -import HsSyn +import GHC.Hs -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot index 65c4f188fd..54864d5835 100644 --- a/compiler/deSugar/DsExpr.hs-boot +++ b/compiler/deSugar/DsExpr.hs-boot @@ -1,8 +1,8 @@ module DsExpr where -import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) +import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) import DsMonad ( DsM ) import CoreSyn ( CoreExpr ) -import HsExtension ( GhcTc) +import GHC.Hs.Extension ( GhcTc) dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 545f26c3f6..43ef2327c5 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -23,7 +23,7 @@ import CoreSyn import DsCCall import DsMonad -import HsSyn +import GHC.Hs import DataCon import CoreUnfold import Id diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index b0d35d0b2a..6b7dac41b3 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -18,7 +18,7 @@ import GhcPrelude import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} Match ( matchSinglePatVar ) -import HsSyn +import GHC.Hs import MkCore import CoreSyn import CoreUtils (bindNonRec) diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 9755bf695b..e826045eb5 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -18,7 +18,7 @@ import GhcPrelude import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) -import HsSyn +import GHC.Hs import TcHsSyn import CoreSyn import MkCore diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index a8d2b7de0f..c37d366d5e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -30,7 +30,7 @@ import DsMonad import qualified Language.Haskell.TH as TH -import HsSyn +import GHC.Hs import PrelNames -- To avoid clashes with DsMeta.varName we must make a local alias for -- OccName.varName we do this by removing varName from the import of diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 1bfa25324a..eac17bfea0 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -59,7 +59,7 @@ import FamInstEnv import CoreSyn import MkCore ( unitExpr ) import CoreUtils ( exprType, isExprLevPoly ) -import HsSyn +import GHC.Hs import TcIface import TcMType ( checkForLevPolyX, formatLevPolyErr ) import PrelNames diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index c4abd16737..7d39b4a3c6 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -49,7 +49,7 @@ import GhcPrelude import {-# SOURCE #-} Match ( matchSimply ) import {-# SOURCE #-} DsExpr ( dsLExpr ) -import HsSyn +import GHC.Hs import TcHsSyn import TcType( tcSplitTyConApp ) import CoreSyn @@ -747,7 +747,7 @@ is_triv_pat _ = False * * Creating big tuples and their types for full Haskell expressions. They work over *Ids*, and create tuples replete with their types, - which is whey they are not in HsUtils. + which is whey they are not in GHC.Hs.Utils. * * ********************************************************************* -} diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs index 4d7f115074..33bed3b3f5 100644 --- a/compiler/deSugar/ExtractDocs.hs +++ b/compiler/deSugar/ExtractDocs.hs @@ -8,12 +8,12 @@ module ExtractDocs (extractDocs) where import GhcPrelude import Bag -import HsBinds -import HsDoc -import HsDecls -import HsExtension -import HsTypes -import HsUtils +import GHC.Hs.Binds +import GHC.Hs.Doc +import GHC.Hs.Decls +import GHC.Hs.Extension +import GHC.Hs.Types +import GHC.Hs.Utils import Name import NameSet import SrcLoc diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index a0576494a0..0049d00613 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -21,7 +21,7 @@ import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr) import BasicTypes ( Origin(..) ) import DynFlags -import HsSyn +import GHC.Hs import TcHsSyn import TcEvidence import TcRnMonad diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot index e77ad548b6..be5cd766ea 100644 --- a/compiler/deSugar/Match.hs-boot +++ b/compiler/deSugar/Match.hs-boot @@ -5,9 +5,9 @@ import Var ( Id ) import TcType ( Type ) import DsMonad ( DsM, EquationInfo, MatchResult ) import CoreSyn ( CoreExpr ) -import HsSyn ( LPat, HsMatchContext, MatchGroup, LHsExpr ) +import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) import Name ( Name ) -import HsExtension ( GhcTc ) +import GHC.Hs.Extension ( GhcTc ) match :: [Id] -> Type diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index ce1f19f560..be65433c3b 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -18,7 +18,7 @@ import GhcPrelude import {-# SOURCE #-} Match ( match ) -import HsSyn +import GHC.Hs import DsBinds import ConLike import BasicTypes ( Origin(..) ) diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 3bab8cf000..126346b935 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -27,7 +27,7 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr ) import DsMonad import DsUtils -import HsSyn +import GHC.Hs import Id import CoreSyn diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index fc5f581a4d..037e7aa0b2 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -177,7 +177,6 @@ Library coreSyn deSugar ghci - hsSyn iface llvmGen main @@ -354,20 +353,20 @@ Library Match MatchCon MatchLit - HsBinds - HsDecls - HsDoc - HsExpr - HsImpExp - HsLit - PlaceHolder - HsExtension - HsInstances - HsPat - HsSyn - HsTypes - HsUtils - HsDumpAst + GHC.Hs + GHC.Hs.Binds + GHC.Hs.Decls + GHC.Hs.Doc + GHC.Hs.Expr + GHC.Hs.ImpExp + GHC.Hs.Lit + GHC.Hs.PlaceHolder + GHC.Hs.Extension + GHC.Hs.Instances + GHC.Hs.Pat + GHC.Hs.Types + GHC.Hs.Utils + GHC.Hs.Dump BinIface BinFingerprint BuildTyCl @@ -663,7 +662,7 @@ Library Dwarf Dwarf.Types Dwarf.Constants - Convert + GHC.ThToHs ByteCodeTypes ByteCodeAsm ByteCodeGen diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 47f21882c9..a1253de735 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -25,7 +25,7 @@ import CoreUtils ( exprType ) import ConLike ( conLikeName ) import Desugar ( deSugarExpr ) import FieldLabel -import HsSyn +import GHC.Hs import HscTypes import Module ( ModuleName, ml_hs_file ) import MonadUtils ( concatMapM, liftIO ) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs deleted file mode 100644 index ee6553ce04..0000000000 --- a/compiler/hsSyn/Convert.hs +++ /dev/null @@ -1,2010 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -This module converts Template Haskell syntax into HsSyn --} - -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module Convert( convertToHsExpr, convertToPat, convertToHsDecls, - convertToHsType, - thRdrNameGuesses ) where - -import GhcPrelude - -import HsSyn as Hs -import PrelNames -import RdrName -import qualified Name -import Module -import RdrHsSyn -import OccName -import SrcLoc -import Type -import qualified Coercion ( Role(..) ) -import TysWiredIn -import BasicTypes as Hs -import ForeignCall -import Unique -import ErrUtils -import Bag -import Lexeme -import Util -import FastString -import Outputable -import MonadUtils ( foldrM ) - -import qualified Data.ByteString as BS -import Control.Monad( unless, ap ) - -import Data.Maybe( catMaybes, isNothing ) -import Language.Haskell.TH as TH hiding (sigP) -import Language.Haskell.TH.Syntax as TH -import Foreign.ForeignPtr -import Foreign.Ptr -import System.IO.Unsafe - -------------------------------------------------------------------- --- The external interface - -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] -convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds)) - where - cvt_dec d = wrapMsg "declaration" d (cvtDec d) - -convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) -convertToHsExpr loc e - = initCvt loc $ wrapMsg "expression" e $ cvtl e - -convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) -convertToPat loc p - = initCvt loc $ wrapMsg "pattern" p $ cvtPat p - -convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) -convertToHsType loc t - = initCvt loc $ wrapMsg "type" t $ cvtType t - -------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) } - deriving (Functor) - -- Push down the source location; - -- Can fail, with a single error message - --- NB: If the conversion succeeds with (Right x), there should --- be no exception values hiding in x --- Reason: so a (head []) in TH code doesn't subsequently --- make GHC crash when it tries to walk the generated tree - --- Use the loc everywhere, for lack of anything better --- In particular, we want it on binding locations, so that variables bound in --- the spliced-in declarations get a location that at least relates to the splice point - -instance Applicative CvtM where - pure x = CvtM $ \loc -> Right (loc,x) - (<*>) = ap - -instance Monad CvtM where - (CvtM m) >>= k = CvtM $ \loc -> case m loc of - Left err -> Left err - Right (loc',v) -> unCvtM (k v) loc' - -initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a -initCvt loc (CvtM m) = fmap snd (m loc) - -force :: a -> CvtM () -force a = a `seq` return () - -failWith :: MsgDoc -> CvtM a -failWith m = CvtM (\_ -> Left m) - -getL :: CvtM SrcSpan -getL = CvtM (\loc -> Right (loc,loc)) - -setL :: SrcSpan -> CvtM () -setL loc = CvtM (\_ -> Right (loc, ())) - -returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a -returnL x = CvtM (\loc -> Right (loc, cL loc x)) - -returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a) -returnJustL = fmap Just . returnL - -wrapParL :: HasSrcSpan a => - (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a) -wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x))) - -wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b --- E.g wrapMsg "declaration" dec thing -wrapMsg what item (CvtM m) - = CvtM (\loc -> case m loc of - Left err -> Left (err $$ getPprStyle msg) - Right v -> Right v) - where - -- Show the item in pretty syntax normally, - -- but with all its constructors if you say -dppr-debug - msg sty = hang (text "When splicing a TH" <+> text what <> colon) - 2 (if debugStyle sty - then text (show item) - else text (pprint item)) - -wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a -wrapL (CvtM m) = CvtM (\loc -> case m loc of - Left err -> Left err - Right (loc',v) -> Right (loc',cL loc v)) - -------------------------------------------------------------------- -cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] -cvtDecs = fmap catMaybes . mapM cvtDec - -cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs)) -cvtDec (TH.ValD pat body ds) - | TH.VarP s <- pat - = do { s' <- vNameL s - ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) - ; returnJustL $ Hs.ValD noExtField $ mkFunBind s' [cl'] } - - | otherwise - = do { pat' <- cvtPat pat - ; body' <- cvtGuard body - ; ds' <- cvtLocalDecs (text "a where clause") ds - ; returnJustL $ Hs.ValD noExtField $ - PatBind { pat_lhs = pat' - , pat_rhs = GRHSs noExtField body' (noLoc ds') - , pat_ext = noExtField - , pat_ticks = ([],[]) } } - -cvtDec (TH.FunD nm cls) - | null cls - = failWith (text "Function binding for" - <+> quotes (text (TH.pprint nm)) - <+> text "has no equations") - | otherwise - = do { nm' <- vNameL nm - ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls - ; returnJustL $ Hs.ValD noExtField $ mkFunBind nm' cls' } - -cvtDec (TH.SigD nm typ) - = do { nm' <- vNameL nm - ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD noExtField - (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) } - -cvtDec (TH.InfixD fx nm) - -- Fixity signatures are allowed for variables, constructors, and types - -- the renamer automatically looks for types during renaming, even when - -- the RdrName says it's a variable or a constructor. So, just assume - -- it's a variable or constructor and proceed. - = do { nm' <- vcNameL nm - ; returnJustL (Hs.SigD noExtField (FixSig noExtField - (FixitySig noExtField [nm'] (cvtFixity fx)))) } - -cvtDec (PragmaD prag) - = cvtPragmaD prag - -cvtDec (TySynD tc tvs rhs) - = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs - ; rhs' <- cvtType rhs - ; returnJustL $ TyClD noExtField $ - SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdRhs = rhs' } } - -cvtDec (DataD ctxt tc tvs ksig constrs derivs) - = do { let isGadtCon (GadtC _ _ _) = True - isGadtCon (RecGadtC _ _ _) = True - isGadtCon (ForallC _ _ c) = isGadtCon c - isGadtCon _ = False - isGadtDecl = all isGadtCon constrs - isH98Decl = all (not . isGadtCon) constrs - ; unless (isGadtDecl || isH98Decl) - (failWith (text "Cannot mix GADT constructors with Haskell 98" - <+> text "constructors")) - ; unless (isNothing ksig || isGadtDecl) - (failWith (text "Kind signatures are only allowed on GADTs")) - ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs - ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM cvtConstr constrs - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = DataType, dd_cType = Nothing - , dd_ctxt = ctxt' - , dd_kindSig = ksig' - , dd_cons = cons', dd_derivs = derivs' } - ; returnJustL $ TyClD noExtField $ - DataDecl { tcdDExt = noExtField - , tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdDataDefn = defn } } - -cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) - = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs - ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr constr - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = NewType, dd_cType = Nothing - , dd_ctxt = ctxt' - , dd_kindSig = ksig' - , dd_cons = [con'] - , dd_derivs = derivs' } - ; returnJustL $ TyClD noExtField $ - DataDecl { tcdDExt = noExtField - , tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdDataDefn = defn } } - -cvtDec (ClassD ctxt cl tvs fds decs) - = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs - ; fds' <- mapM cvt_fundep fds - ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs - ; unless (null adts') - (failWith $ (text "Default data instance declarations" - <+> text "are not allowed:") - $$ (Outputable.ppr adts')) - ; returnJustL $ TyClD noExtField $ - ClassDecl { tcdCExt = noExtField - , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' - , tcdMeths = binds' - , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] } - -- no docs in TH ^^ - } - -cvtDec (InstanceD o ctxt ty decs) - = do { let doc = text "an instance declaration" - ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs - ; unless (null fams') (failWith (mkBadDecMsg doc fams')) - ; ctxt' <- cvtContext funPrec ctxt - ; (dL->L loc ty') <- cvtType ty - ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty' - ; returnJustL $ InstD noExtField $ ClsInstD noExtField $ - ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty' - , cid_binds = binds' - , cid_sigs = Hs.mkClassOpSigs sigs' - , cid_tyfam_insts = ats', cid_datafam_insts = adts' - , cid_overlap_mode = fmap (cL loc . overlap) o } } - where - overlap pragma = - case pragma of - TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS") - TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE") - TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING") - TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT") - - - - -cvtDec (ForeignD ford) - = do { ford' <- cvtForD ford - ; returnJustL $ ForD noExtField ford' } - -cvtDec (DataFamilyD tc tvs kind) - = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs - ; result <- cvtMaybeKindToFamilyResultSig kind - ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ - FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing } - -cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) - = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys - ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM cvtConstr constrs - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = DataType, dd_cType = Nothing - , dd_ctxt = ctxt' - , dd_kindSig = ksig' - , dd_cons = cons', dd_derivs = derivs' } - - ; returnJustL $ InstD noExtField $ DataFamInstD - { dfid_ext = noExtField - , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ - FamEqn { feqn_ext = noExtField - , feqn_tycon = tc' - , feqn_bndrs = bndrs' - , feqn_pats = typats' - , feqn_rhs = defn - , feqn_fixity = Prefix } }}} - -cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) - = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys - ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr constr - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = NewType, dd_cType = Nothing - , dd_ctxt = ctxt' - , dd_kindSig = ksig' - , dd_cons = [con'], dd_derivs = derivs' } - ; returnJustL $ InstD noExtField $ DataFamInstD - { dfid_ext = noExtField - , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $ - FamEqn { feqn_ext = noExtField - , feqn_tycon = tc' - , feqn_bndrs = bndrs' - , feqn_pats = typats' - , feqn_rhs = defn - , feqn_fixity = Prefix } }}} - -cvtDec (TySynInstD eqn) - = do { (dL->L _ eqn') <- cvtTySynEqn eqn - ; returnJustL $ InstD noExtField $ TyFamInstD - { tfid_ext = noExtField - , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } - -cvtDec (OpenTypeFamilyD head) - = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head - ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ - FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity' - } - -cvtDec (ClosedTypeFamilyD head eqns) - = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head - ; eqns' <- mapM cvtTySynEqn eqns - ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ - FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix - result' injectivity' } - -cvtDec (TH.RoleAnnotD tc roles) - = do { tc' <- tconNameL tc - ; let roles' = map (noLoc . cvtRole) roles - ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') } - -cvtDec (TH.StandaloneDerivD ds cxt ty) - = do { cxt' <- cvtContext funPrec cxt - ; ds' <- traverse cvtDerivStrategy ds - ; (dL->L loc ty') <- cvtType ty - ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty' - ; returnJustL $ DerivD noExtField $ - DerivDecl { deriv_ext =noExtField - , deriv_strategy = ds' - , deriv_type = mkLHsSigWcType inst_ty' - , deriv_overlap_mode = Nothing } } - -cvtDec (TH.DefaultSigD nm typ) - = do { nm' <- vNameL nm - ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD noExtField - $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')} - -cvtDec (TH.PatSynD nm args dir pat) - = do { nm' <- cNameL nm - ; args' <- cvtArgs args - ; dir' <- cvtDir nm' dir - ; pat' <- cvtPat pat - ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $ - PSB noExtField nm' args' pat' dir' } - where - cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args - cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2 - cvtArgs (TH.RecordPatSyn sels) - = do { sels' <- mapM vNameL sels - ; vars' <- mapM (vNameL . mkNameS . nameBase) sels - ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } - - cvtDir _ Unidir = return Unidirectional - cvtDir _ ImplBidir = return ImplicitBidirectional - cvtDir n (ExplBidir cls) = - do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls - ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } - -cvtDec (TH.PatSynSigD nm ty) - = do { nm' <- cNameL nm - ; ty' <- cvtPatSynSigTy ty - ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')} - --- Implicit parameter bindings are handled in cvtLocalDecs and --- cvtImplicitParamBind. They are not allowed in any other scope, so --- reaching this case indicates an error. -cvtDec (TH.ImplicitParamBindD _ _) - = failWith (text "Implicit parameter binding only allowed in let or where") - ----------------- -cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) -cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) - = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs - ; (head_ty, args) <- split_ty_app lhs - ; case head_ty of - ConT nm -> do { nm' <- tconNameL nm - ; rhs' <- cvtType rhs - ; let args' = map wrap_tyarg args - ; returnL $ mkHsImplicitBndrs - $ FamEqn { feqn_ext = noExtField - , feqn_tycon = nm' - , feqn_bndrs = mb_bndrs' - , feqn_pats = args' - , feqn_fixity = Prefix - , feqn_rhs = rhs' } } - InfixT t1 nm t2 -> do { nm' <- tconNameL nm - ; args' <- mapM cvtType [t1,t2] - ; rhs' <- cvtType rhs - ; returnL $ mkHsImplicitBndrs - $ FamEqn { feqn_ext = noExtField - , feqn_tycon = nm' - , feqn_bndrs = mb_bndrs' - , feqn_pats = - (map HsValArg args') ++ args - , feqn_fixity = Hs.Infix - , feqn_rhs = rhs' } } - _ -> failWith $ text "Invalid type family instance LHS:" - <+> text (show lhs) - } - ----------------- -cvt_ci_decs :: MsgDoc -> [TH.Dec] - -> CvtM (LHsBinds GhcPs, - [LSig GhcPs], - [LFamilyDecl GhcPs], - [LTyFamInstDecl GhcPs], - [LDataFamInstDecl GhcPs]) --- Convert the declarations inside a class or instance decl --- ie signatures, bindings, and associated types -cvt_ci_decs doc decs - = do { decs' <- cvtDecs decs - ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs' - ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs' - ; let (sigs', prob_binds') = partitionWith is_sig no_ats' - ; let (binds', prob_fams') = partitionWith is_bind prob_binds' - ; let (fams', bads) = partitionWith is_fam_decl prob_fams' - ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - --We use FromSource as the origin of the bind - -- because the TH declaration is user-written - ; return (listToBag binds', sigs', fams', ats', adts') } - ----------------- -cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] - -> CvtM ( LHsContext GhcPs - , Located RdrName - , LHsQTyVars GhcPs) -cvt_tycl_hdr cxt tc tvs - = do { cxt' <- cvtContext funPrec cxt - ; tc' <- tconNameL tc - ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') - } - -cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type - -> CvtM ( LHsContext GhcPs - , Located RdrName - , Maybe [LHsTyVarBndr GhcPs] - , HsTyPats GhcPs) -cvt_datainst_hdr cxt bndrs tys - = do { cxt' <- cvtContext funPrec cxt - ; bndrs' <- traverse (mapM cvt_tv) bndrs - ; (head_ty, args) <- split_ty_app tys - ; case head_ty of - ConT nm -> do { nm' <- tconNameL nm - ; let args' = map wrap_tyarg args - ; return (cxt', nm', bndrs', args') } - InfixT t1 nm t2 -> do { nm' <- tconNameL nm - ; args' <- mapM cvtType [t1,t2] - ; return (cxt', nm', bndrs', - ((map HsValArg args') ++ args)) } - _ -> failWith $ text "Invalid type instance header:" - <+> text (show tys) } - ----------------- -cvt_tyfam_head :: TypeFamilyHead - -> CvtM ( Located RdrName - , LHsQTyVars GhcPs - , Hs.LFamilyResultSig GhcPs - , Maybe (Hs.LInjectivityAnn GhcPs)) - -cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) - = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars - ; result' <- cvtFamilyResultSig result - ; injectivity' <- traverse cvtInjectivityAnnotation injectivity - ; return (tc', tyvars', result', injectivity') } - -------------------------------------------------------------------- --- Partitioning declarations -------------------------------------------------------------------- - -is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs) -is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d) -is_fam_decl decl = Right decl - -is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs) -is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d }))) - = Left (cL loc d) -is_tyfam_inst decl - = Right decl - -is_datafam_inst :: LHsDecl GhcPs - -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs) -is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d }))) - = Left (cL loc d) -is_datafam_inst decl - = Right decl - -is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs) -is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig) -is_sig decl = Right decl - -is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs) -is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind) -is_bind decl = Right decl - -is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec -is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) -is_ip_bind decl = Right decl - -mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc -mkBadDecMsg doc bads - = sep [ text "Illegal declaration(s) in" <+> doc <> colon - , nest 2 (vcat (map Outputable.ppr bads)) ] - ---------------------------------------------------- --- Data types ---------------------------------------------------- - -cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) - -cvtConstr (NormalC c strtys) - = do { c' <- cNameL c - ; tys' <- mapM cvt_arg strtys - ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') } - -cvtConstr (RecC c varstrtys) - = do { c' <- cNameL c - ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ mkConDeclH98 c' Nothing Nothing - (RecCon (noLoc args')) } - -cvtConstr (InfixC st1 c st2) - = do { c' <- cNameL c - ; st1' <- cvt_arg st1 - ; st2' <- cvt_arg st2 - ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') } - -cvtConstr (ForallC tvs ctxt con) - = do { tvs' <- cvtTvs tvs - ; ctxt' <- cvtContext funPrec ctxt - ; (dL->L _ con') <- cvtConstr con - ; returnL $ add_forall tvs' ctxt' con' } - where - add_cxt lcxt Nothing = Just lcxt - add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2)) - = Just (cL loc (cxt1 ++ cxt2)) - - add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) - = con { con_forall = noLoc $ not (null all_tvs) - , con_qvars = mkHsQTvs all_tvs - , con_mb_cxt = add_cxt cxt' cxt } - where - all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars - - add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) - = con { con_forall = noLoc $ not (null all_tvs) - , con_ex_tvs = all_tvs - , con_mb_cxt = add_cxt cxt' cxt } - where - all_tvs = hsQTvExplicit tvs' ++ ex_tvs - - add_forall _ _ (XConDecl nec) = noExtCon nec - -cvtConstr (GadtC c strtys ty) - = do { c' <- mapM cNameL c - ; args <- mapM cvt_arg strtys - ; (dL->L _ ty') <- cvtType ty - ; c_ty <- mk_arr_apps args ty' - ; returnL $ fst $ mkGadtDecl c' c_ty} - -cvtConstr (RecGadtC c varstrtys ty) - = do { c' <- mapM cNameL c - ; ty' <- cvtType ty - ; rec_flds <- mapM cvt_id_arg varstrtys - ; let rec_ty = noLoc (HsFunTy noExtField - (noLoc $ HsRecTy noExtField rec_flds) ty') - ; returnL $ fst $ mkGadtDecl c' rec_ty } - -cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness -cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack -cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack -cvtSrcUnpackedness SourceUnpack = SrcUnpack - -cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness -cvtSrcStrictness NoSourceStrictness = NoSrcStrict -cvtSrcStrictness SourceLazy = SrcLazy -cvtSrcStrictness SourceStrict = SrcStrict - -cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs) -cvt_arg (Bang su ss, ty) - = do { ty'' <- cvtType ty - ; let ty' = parenthesizeHsType appPrec ty'' - su' = cvtSrcUnpackedness su - ss' = cvtSrcStrictness ss - ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' } - -cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) -cvt_id_arg (i, str, ty) - = do { (dL->L li i') <- vNameL i - ; ty' <- cvt_arg (str,ty) - ; return $ noLoc (ConDeclField - { cd_fld_ext = noExtField - , cd_fld_names - = [cL li $ FieldOcc noExtField (cL li i')] - , cd_fld_type = ty' - , cd_fld_doc = Nothing}) } - -cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) -cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs - ; returnL cs' } - -cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs) -cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs - ; ys' <- mapM tNameL ys - ; returnL (xs', ys') } - - ------------------------------------------- --- Foreign declarations ------------------------------------------- - -cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) -cvtForD (ImportF callconv safety from nm ty) - -- the prim and javascript calling conventions do not support headers - -- and are inserted verbatim, analogous to mkImport in RdrHsSyn - | callconv == TH.Prim || callconv == TH.JavaScript - = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing - (CFunction (StaticTarget (SourceText from) - (mkFastString from) Nothing - True)) - (noLoc $ quotedSourceText from)) - | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') - (mkFastString (TH.nameBase nm)) - from (noLoc $ quotedSourceText from) - = mk_imp impspec - | otherwise - = failWith $ text (show from) <+> text "is not a valid ccall impent" - where - mk_imp impspec - = do { nm' <- vNameL nm - ; ty' <- cvtType ty - ; return (ForeignImport { fd_i_ext = noExtField - , fd_name = nm' - , fd_sig_ty = mkLHsSigType ty' - , fd_fi = impspec }) - } - safety' = case safety of - Unsafe -> PlayRisky - Safe -> PlaySafe - Interruptible -> PlayInterruptible - -cvtForD (ExportF callconv as nm ty) - = do { nm' <- vNameL nm - ; ty' <- cvtType ty - ; let e = CExport (noLoc (CExportStatic (SourceText as) - (mkFastString as) - (cvt_conv callconv))) - (noLoc (SourceText as)) - ; return $ ForeignExport { fd_e_ext = noExtField - , fd_name = nm' - , fd_sig_ty = mkLHsSigType ty' - , fd_fe = e } } - -cvt_conv :: TH.Callconv -> CCallConv -cvt_conv TH.CCall = CCallConv -cvt_conv TH.StdCall = StdCallConv -cvt_conv TH.CApi = CApiConv -cvt_conv TH.Prim = PrimCallConv -cvt_conv TH.JavaScript = JavaScriptCallConv - ------------------------------------------- --- Pragmas ------------------------------------------- - -cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) -cvtPragmaD (InlineP nm inline rm phases) - = do { nm' <- vNameL nm - ; let dflt = dfltActivation inline - ; let src TH.NoInline = "{-# NOINLINE" - src TH.Inline = "{-# INLINE" - src TH.Inlinable = "{-# INLINABLE" - ; let ip = InlinePragma { inl_src = SourceText $ src inline - , inl_inline = cvtInline inline - , inl_rule = cvtRuleMatch rm - , inl_act = cvtPhases phases dflt - , inl_sat = Nothing } - ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip } - -cvtPragmaD (SpecialiseP nm ty inline phases) - = do { nm' <- vNameL nm - ; ty' <- cvtType ty - ; let src TH.NoInline = "{-# SPECIALISE NOINLINE" - src TH.Inline = "{-# SPECIALISE INLINE" - src TH.Inlinable = "{-# SPECIALISE INLINE" - ; let (inline', dflt,srcText) = case inline of - Just inline1 -> (cvtInline inline1, dfltActivation inline1, - src inline1) - Nothing -> (NoUserInline, AlwaysActive, - "{-# SPECIALISE") - ; let ip = InlinePragma { inl_src = SourceText srcText - , inl_inline = inline' - , inl_rule = Hs.FunLike - , inl_act = cvtPhases phases dflt - , inl_sat = Nothing } - ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip } - -cvtPragmaD (SpecialiseInstP ty) - = do { ty' <- cvtType ty - ; returnJustL $ Hs.SigD noExtField $ - SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } - -cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) - = do { let nm' = mkFastString nm - ; let act = cvtPhases phases AlwaysActive - ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs - ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs - ; lhs' <- cvtl lhs - ; rhs' <- cvtl rhs - ; returnJustL $ Hs.RuleD noExtField - $ HsRules { rds_ext = noExtField - , rds_src = SourceText "{-# RULES" - , rds_rules = [noLoc $ - HsRule { rd_ext = noExtField - , rd_name = (noLoc (quotedSourceText nm,nm')) - , rd_act = act - , rd_tyvs = ty_bndrs' - , rd_tmvs = tm_bndrs' - , rd_lhs = lhs' - , rd_rhs = rhs' }] } - - } - -cvtPragmaD (AnnP target exp) - = do { exp' <- cvtl exp - ; target' <- case target of - ModuleAnnotation -> return ModuleAnnProvenance - TypeAnnotation n -> do - n' <- tconName n - return (TypeAnnProvenance (noLoc n')) - ValueAnnotation n -> do - n' <- vcName n - return (ValueAnnProvenance (noLoc n')) - ; returnJustL $ Hs.AnnD noExtField - $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp' - } - -cvtPragmaD (LineP line file) - = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1)) - ; return Nothing - } -cvtPragmaD (CompleteP cls mty) - = do { cls' <- noLoc <$> mapM cNameL cls - ; mty' <- traverse tconNameL mty - ; returnJustL $ Hs.SigD noExtField - $ CompleteMatchSig noExtField NoSourceText cls' mty' } - -dfltActivation :: TH.Inline -> Activation -dfltActivation TH.NoInline = NeverActive -dfltActivation _ = AlwaysActive - -cvtInline :: TH.Inline -> Hs.InlineSpec -cvtInline TH.NoInline = Hs.NoInline -cvtInline TH.Inline = Hs.Inline -cvtInline TH.Inlinable = Hs.Inlinable - -cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo -cvtRuleMatch TH.ConLike = Hs.ConLike -cvtRuleMatch TH.FunLike = Hs.FunLike - -cvtPhases :: TH.Phases -> Activation -> Activation -cvtPhases AllPhases dflt = dflt -cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i -cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i - -cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) -cvtRuleBndr (RuleVar n) - = do { n' <- vNameL n - ; return $ noLoc $ Hs.RuleBndr noExtField n' } -cvtRuleBndr (TypedRuleVar n ty) - = do { n' <- vNameL n - ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' } - ---------------------------------------------------- --- Declarations ---------------------------------------------------- - -cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) -cvtLocalDecs doc ds - = case partitionWith is_ip_bind ds of - ([], []) -> return (EmptyLocalBinds noExtField) - ([], _) -> do - ds' <- cvtDecs ds - let (binds, prob_sigs) = partitionWith is_bind ds' - let (sigs, bads) = partitionWith is_sig prob_sigs - unless (null bads) (failWith (mkBadDecMsg doc bads)) - return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs)) - (ip_binds, []) -> do - binds <- mapM (uncurry cvtImplicitParamBind) ip_binds - return (HsIPBinds noExtField (IPBinds noExtField binds)) - ((_:_), (_:_)) -> - failWith (text "Implicit parameters mixed with other bindings") - -cvtClause :: HsMatchContext RdrName - -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) -cvtClause ctxt (Clause ps body wheres) - = do { ps' <- cvtPats ps - ; let pps = map (parenthesizePat appPrec) ps' - ; g' <- cvtGuard body - ; ds' <- cvtLocalDecs (text "a where clause") wheres - ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) } - -cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) -cvtImplicitParamBind n e = do - n' <- wrapL (ipName n) - e' <- cvtl e - returnL (IPBind noExtField (Left n') e') - -------------------------------------------------------------------- --- Expressions -------------------------------------------------------------------- - -cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) -cvtl e = wrapL (cvt e) - where - cvt (VarE s) = do { s' <- vName s; return $ HsVar noExtField (noLoc s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar noExtField (noLoc s') } - cvt (LitE l) - | overloadedLit l = go cvtOverLit (HsOverLit noExtField) - (hsOverLitNeedsParens appPrec) - | otherwise = go cvtLit (HsLit noExtField) - (hsLitNeedsParens appPrec) - where - go :: (Lit -> CvtM (l GhcPs)) - -> (l GhcPs -> HsExpr GhcPs) - -> (l GhcPs -> Bool) - -> CvtM (HsExpr GhcPs) - go cvt_lit mk_expr is_compound_lit = do - l' <- cvt_lit l - let e' = mk_expr l' - return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e' - cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp noExtField (mkLHsPar x') - (mkLHsPar y')} - cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp noExtField (mkLHsPar x') - (mkLHsPar y')} - cvt (AppTypeE e t) = do { e' <- cvtl e - ; t' <- cvtType t - ; let tp = parenthesizeHsType appPrec t' - ; return $ HsAppType noExtField e' - $ mkHsWildCardBndrs tp } - cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its - -- own expression to avoid pretty-printing - -- oddities that can result from zero-argument - -- lambda expressions. See #13856. - cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e - ; let pats = map (parenthesizePat appPrec) ps' - ; return $ HsLam noExtField (mkMatchGroup FromSource - [mkSimpleMatch LambdaExpr - pats e'])} - cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms - ; return $ HsLamCase noExtField - (mkMatchGroup FromSource ms') - } - cvt (TupE [Just e]) = do { e' <- cvtl e; return $ HsPar noExtField e' } - -- Note [Dropping constructors] - -- Singleton tuples treated like nothing (just parens) - cvt (TupE es) = cvt_tup es Boxed - cvt (UnboxedTupE es) = cvt_tup es Unboxed - cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e - ; unboxedSumChecks alt arity - ; return $ ExplicitSum noExtField - alt arity e'} - cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; - ; return $ HsIf noExtField (Just noSyntaxExpr) x' y' z' } - cvt (MultiIfE alts) - | null alts = failWith (text "Multi-way if-expression with no alternatives") - | otherwise = do { alts' <- mapM cvtpair alts - ; return $ HsMultiIf noExtField alts' } - cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds - ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'} - cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms - ; return $ HsCase noExtField e' - (mkMatchGroup FromSource ms') } - cvt (DoE ss) = cvtHsDo DoExpr ss - cvt (MDoE ss) = cvtHsDo MDoExpr ss - cvt (CompE ss) = cvtHsDo ListComp ss - cvt (ArithSeqE dd) = do { dd' <- cvtDD dd - ; return $ ArithSeq noExtField Nothing dd' } - cvt (ListE xs) - | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) - ; return (HsLit noExtField l') } - -- Note [Converting strings] - | otherwise = do { xs' <- mapM cvtl xs - ; return $ ExplicitList noExtField Nothing xs' - } - - -- Infix expressions - cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $ - do { x' <- cvtl x - ; s' <- cvtl s - ; y' <- cvtl y - ; let px = parenthesizeHsExpr opPrec x' - py = parenthesizeHsExpr opPrec y' - ; wrapParL (HsPar noExtField) - $ OpApp noExtField px s' py } - -- Parenthesise both arguments and result, - -- to ensure this operator application does - -- does not get re-associated - -- See Note [Operator association] - cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $ - do { s' <- cvtl s; y' <- cvtl y - ; wrapParL (HsPar noExtField) $ - SectionR noExtField s' y' } - -- See Note [Sections in HsSyn] in HsExpr - cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $ - do { x' <- cvtl x; s' <- cvtl s - ; wrapParL (HsPar noExtField) $ - SectionL noExtField x' s' } - - cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $ - do { s' <- cvtl s - ; return $ HsPar noExtField s' } - -- Can I indicate this is an infix thing? - -- Note [Dropping constructors] - - cvt (UInfixE x s y) = ensureValidOpExp s $ - do { x' <- cvtl x - ; let x'' = case unLoc x' of - OpApp {} -> x' - _ -> mkLHsPar x' - ; cvtOpApp x'' s y } -- Note [Converting UInfix] - - cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExtField e' } - cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t - ; let pe = parenthesizeHsExpr sigPrec e' - ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') } - cvt (RecConE c flds) = do { c' <- cNameL c - ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds - ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } - cvt (RecUpdE e flds) = do { e' <- cvtl e - ; flds' - <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) - flds - ; return $ mkRdrRecordUpd e' flds' } - cvt (StaticE e) = fmap (HsStatic noExtField) $ cvtl e - cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is - -- important, because UnboundVarE may contain - -- constructor names - see #14627. - { s' <- vcName s - ; return $ HsVar noExtField (noLoc s') } - cvt (LabelE s) = do { return $ HsOverLabel noExtField Nothing (fsLit s) } - cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } - -{- | #16895 Ensure an infix expression's operator is a variable/constructor. -Consider this example: - - $(uInfixE [|1|] [|id id|] [|2|]) - -This infix expression is obviously ill-formed so we use this helper function -to reject such programs outright. - -The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp` -in Language.Haskell.TH.Ppr from the template-haskell library. --} -ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a -ensureValidOpExp (VarE _n) m = m -ensureValidOpExp (ConE _n) m = m -ensureValidOpExp (UnboundVarE _n) m = m -ensureValidOpExp _e _m = - failWith (text "Non-variable expression is not allowed in an infix expression") - -{- Note [Dropping constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we drop constructors from the input (for instance, when we encounter @TupE [e]@) -we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@ -could meet @UInfix@ constructors containing the @TupE [e]@. For example: - - UInfixE x * (TupE [UInfixE y + z]) - -If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet -and the above expression would be reassociated to - - OpApp (OpApp x * y) + z - -which we don't want. --} - -cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) - -> CvtM (LHsRecField' t (LHsExpr GhcPs)) -cvtFld f (v,e) - = do { v' <- vNameL v; e' <- cvtl e - ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v' - , hsRecFieldArg = e' - , hsRecPun = False}) } - -cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) -cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } -cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' } -cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } -cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } - -cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs) -cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg - cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e) - ; es' <- mapM cvtl_maybe es - ; return $ ExplicitTuple - noExtField - (map noLoc es') - boxity } - -{- Note [Operator assocation] -We must be quite careful about adding parens: - * Infix (UInfix ...) op arg Needs parens round the first arg - * Infix (Infix ...) op arg Needs parens round the first arg - * UInfix (UInfix ...) op arg No parens for first arg - * UInfix (Infix ...) op arg Needs parens round first arg - - -Note [Converting UInfix] -~~~~~~~~~~~~~~~~~~~~~~~~ -When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust -the trees to reflect the fixities of the underlying operators: - - UInfixE x * (UInfixE y + z) ---> (x * y) + z - -This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and -@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely -right-biased for types and left-biased for everything else. So we left-bias the -trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. - -Sample input: - - UInfixE - (UInfixE x op1 y) - op2 - (UInfixE z op3 w) - -Sample output: - - OpApp - (OpApp - (OpApp x op1 y) - op2 - z) - op3 - w - -The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this -biasing. --} - -{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. -The produced tree of infix expressions will be left-biased, provided @x@ is. - -We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis -is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that -this holds for both branches (of @cvtOpApp@), provided we assume it holds for -the recursive calls to @cvtOpApp@. - -When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased -since we have already run @cvtl@ on it. --} -cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs) -cvtOpApp x op1 (UInfixE y op2 z) - = do { l <- wrapL $ cvtOpApp x op1 y - ; cvtOpApp l op2 z } -cvtOpApp x op y - = do { op' <- cvtl op - ; y' <- cvtl y - ; return (OpApp noExtField x op' y') } - -------------------------------------- --- Do notation and statements -------------------------------------- - -cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs) -cvtHsDo do_or_lc stmts - | null stmts = failWith (text "Empty stmt list in do-block") - | otherwise - = do { stmts' <- cvtStmts stmts - ; let Just (stmts'', last') = snocView stmts' - - ; last'' <- case last' of - (dL->L loc (BodyStmt _ body _ _)) - -> return (cL loc (mkLastStmt body)) - _ -> failWith (bad_last last') - - ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) } - where - bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon - , nest 2 $ Outputable.ppr stmt - , text "(It should be an expression.)" ] - -cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] -cvtStmts = mapM cvtStmt - -cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) -cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } -cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } -cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds - ; returnL $ LetStmt noExtField (noLoc ds') } -cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss - ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr } - where - cvt_one ds = do { ds' <- cvtStmts ds - ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } -cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') } - -cvtMatch :: HsMatchContext RdrName - -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) -cvtMatch ctxt (TH.Match p body decs) - = do { p' <- cvtPat p - ; let lp = case p' of - (dL->L loc SigPat{}) -> cL loc (ParPat noExtField p') -- #14875 - _ -> p' - ; g' <- cvtGuard body - ; decs' <- cvtLocalDecs (text "a where clause") decs - ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) } - -cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] -cvtGuard (GuardedB pairs) = mapM cvtpair pairs -cvtGuard (NormalB e) = do { e' <- cvtl e - ; g' <- returnL $ GRHS noExtField [] e'; return [g'] } - -cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) -cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs - ; g' <- returnL $ mkBodyStmt ge' - ; returnL $ GRHS noExtField [g'] rhs' } -cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs - ; returnL $ GRHS noExtField gs' rhs' } - -cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) -cvtOverLit (IntegerL i) - = do { force i; return $ mkHsIntegral (mkIntegralLit i) } -cvtOverLit (RationalL r) - = do { force r; return $ mkHsFractional (mkFractionalLit r) } -cvtOverLit (StringL s) - = do { let { s' = mkFastString s } - ; force s' - ; return $ mkHsIsString (quotedSourceText s) s' - } -cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" --- An Integer is like an (overloaded) '3' in a Haskell source program --- Similarly 3.5 for fractionals - -{- Note [Converting strings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to -a string literal for "xy". Of course, we might hope to get -(LitE (StringL "xy")), but not always, and allCharLs fails quickly -if it isn't a literal string --} - -allCharLs :: [TH.Exp] -> Maybe String --- Note [Converting strings] --- NB: only fire up this setup for a non-empty list, else --- there's a danger of returning "" for [] :: [Int]! -allCharLs xs - = case xs of - LitE (CharL c) : ys -> go [c] ys - _ -> Nothing - where - go cs [] = Just (reverse cs) - go cs (LitE (CharL c) : ys) = go (c:cs) ys - go _ _ = Nothing - -cvtLit :: Lit -> CvtM (HsLit GhcPs) -cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } -cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } -cvtLit (FloatPrimL f) - = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) } -cvtLit (DoublePrimL f) - = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) } -cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } -cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } -cvtLit (StringL s) = do { let { s' = mkFastString s } - ; force s' - ; return $ HsString (quotedSourceText s) s' } -cvtLit (StringPrimL s) = do { let { s' = BS.pack s } - ; force s' - ; return $ HsStringPrim NoSourceText s' } -cvtLit (BytesPrimL (Bytes fptr off sz)) = do - let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr -> - BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz) - force bs - return $ HsStringPrim NoSourceText bs -cvtLit _ = panic "Convert.cvtLit: Unexpected literal" - -- cvtLit should not be called on IntegerL, RationalL - -- That precondition is established right here in - -- Convert.hs, hence panic - -quotedSourceText :: String -> SourceText -quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" - -cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] -cvtPats pats = mapM cvtPat pats - -cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs) -cvtPat pat = wrapL (cvtp pat) - -cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) -cvtp (TH.LitP l) - | overloadedLit l = do { l' <- cvtOverLit l - ; return (mkNPat (noLoc l') Nothing) } - -- Not right for negative patterns; - -- need to think about that! - | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } -cvtp (TH.VarP s) = do { s' <- vName s - ; return $ Hs.VarPat noExtField (noLoc s') } -cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExtField p' } - -- Note [Dropping constructors] -cvtp (TupP ps) = do { ps' <- cvtPats ps - ; return $ TuplePat noExtField ps' Boxed } -cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps - ; return $ TuplePat noExtField ps' Unboxed } -cvtp (UnboxedSumP p alt arity) - = do { p' <- cvtPat p - ; unboxedSumChecks alt arity - ; return $ SumPat noExtField p' alt arity } -cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps - ; let pps = map (parenthesizePat appPrec) ps' - ; return $ ConPatIn s' (PrefixCon pps) } -cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; wrapParL (ParPat noExtField) $ - ConPatIn s' $ - InfixCon (parenthesizePat opPrec p1') - (parenthesizePat opPrec p2') } - -- See Note [Operator association] -cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] -cvtp (ParensP p) = do { p' <- cvtPat p; - ; case unLoc p' of -- may be wrapped ConPatIn - ParPat {} -> return $ unLoc p' - _ -> return $ ParPat noExtField p' } -cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExtField p' } -cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExtField p' } -cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p - ; return $ AsPat noExtField s' p' } -cvtp TH.WildP = return $ WildPat noExtField -cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' - $ Hs.RecCon (HsRecFields fs' Nothing) } -cvtp (ListP ps) = do { ps' <- cvtPats ps - ; return - $ ListPat noExtField ps'} -cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat noExtField p' (mkLHsSigWcType t') } -cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p - ; return $ ViewPat noExtField e' p'} - -cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) -cvtPatFld (s,p) - = do { (dL->L ls s') <- vNameL s - ; p' <- cvtPat p - ; return (noLoc $ HsRecField { hsRecFieldLbl - = cL ls $ mkFieldOcc (cL ls s') - , hsRecFieldArg = p' - , hsRecPun = False}) } - -{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. -The produced tree of infix patterns will be left-biased, provided @x@ is. - -See the @cvtOpApp@ documentation for how this function works. --} -cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs) -cvtOpAppP x op1 (UInfixP y op2 z) - = do { l <- wrapL $ cvtOpAppP x op1 y - ; cvtOpAppP l op2 z } -cvtOpAppP x op y - = do { op' <- cNameL op - ; y' <- cvtPat y - ; return (ConPatIn op' (InfixCon x y')) } - ------------------------------------------------------------ --- Types and type variables - -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) -cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } - -cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) -cvt_tv (TH.PlainTV nm) - = do { nm' <- tNameL nm - ; returnL $ UserTyVar noExtField nm' } -cvt_tv (TH.KindedTV nm ki) - = do { nm' <- tNameL nm - ; ki' <- cvtKind ki - ; returnL $ KindedTyVar noExtField nm' ki' } - -cvtRole :: TH.Role -> Maybe Coercion.Role -cvtRole TH.NominalR = Just Coercion.Nominal -cvtRole TH.RepresentationalR = Just Coercion.Representational -cvtRole TH.PhantomR = Just Coercion.Phantom -cvtRole TH.InferR = Nothing - -cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs) -cvtContext p tys = do { preds' <- mapM cvtPred tys - ; parenthesizeHsContext p <$> returnL preds' } - -cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) -cvtPred = cvtType - -cvtDerivClause :: TH.DerivClause - -> CvtM (LHsDerivingClause GhcPs) -cvtDerivClause (TH.DerivClause ds ctxt) - = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt - ; ds' <- traverse cvtDerivStrategy ds - ; returnL $ HsDerivingClause noExtField ds' ctxt' } - -cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) -cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy -cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy -cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy -cvtDerivStrategy (TH.ViaStrategy ty) = do - ty' <- cvtType ty - returnL $ Hs.ViaStrategy (mkLHsSigType ty') - -cvtType :: TH.Type -> CvtM (LHsType GhcPs) -cvtType = cvtTypeKind "type" - -cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) -cvtTypeKind ty_str ty - = do { (head_ty, tys') <- split_ty_app ty - ; let m_normals = mapM extract_normal tys' - where extract_normal (HsValArg ty) = Just ty - extract_normal _ = Nothing - - ; case head_ty of - TupleT n - | Just normals <- m_normals - , normals `lengthIs` n -- Saturated - -> if n==1 then return (head normals) -- Singleton tuples treated - -- like nothing (ie just parens) - else returnL (HsTupleTy noExtField - HsBoxedOrConstraintTuple normals) - | n == 1 - -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) - | otherwise - -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) - tys' - UnboxedTupleT n - | Just normals <- m_normals - , normals `lengthIs` n -- Saturated - -> returnL (HsTupleTy noExtField HsUnboxedTuple normals) - | otherwise - -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) - tys' - UnboxedSumT n - | n < 2 - -> failWith $ - vcat [ text "Illegal sum arity:" <+> text (show n) - , nest 2 $ - text "Sums must have an arity of at least 2" ] - | Just normals <- m_normals - , normals `lengthIs` n -- Saturated - -> returnL (HsSumTy noExtField normals) - | otherwise - -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n)))) - tys' - ArrowT - | Just normals <- m_normals - , [x',y'] <- normals -> do - x'' <- case unLoc x' of - HsFunTy{} -> returnL (HsParTy noExtField x') - HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646 - HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324 - _ -> return $ - parenthesizeHsType sigPrec x' - let y'' = parenthesizeHsType sigPrec y' - returnL (HsFunTy noExtField x'' y'') - | otherwise - -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon))) - tys' - ListT - | Just normals <- m_normals - , [x'] <- normals -> do - returnL (HsListTy noExtField x') - | otherwise - -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon))) - tys' - - VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' } - ConT nm -> do { nm' <- tconName nm - ; -- ConT can contain both data constructor (i.e., - -- promoted) names and other (i.e, unpromoted) - -- names, as opposed to PromotedT, which can only - -- contain data constructor names. See #15572. - let prom = if isRdrDataCon nm' - then IsPromoted - else NotPromoted - ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'} - - ForallT tvs cxt ty - | null tys' - -> do { tvs' <- cvtTvs tvs - ; cxt' <- cvtContext funPrec cxt - ; ty' <- cvtType ty - ; loc <- getL - ; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty - rho_ty = mkHsQualTy cxt loc cxt' ty' - - ; return hs_ty } - - ForallVisT tvs ty - | null tys' - -> do { tvs' <- cvtTvs tvs - ; ty' <- cvtType ty - ; loc <- getL - ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' } - - SigT ty ki - -> do { ty' <- cvtType ty - ; ki' <- cvtKind ki - ; mk_apps (HsKindSig noExtField ty' ki') tys' - } - - LitT lit - -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys' - - WildCardT - -> mk_apps mkAnonWildCardTy tys' - - InfixT t1 s t2 - -> do { s' <- tconName s - ; t1' <- cvtType t1 - ; t2' <- cvtType t2 - ; mk_apps - (HsTyVar noExtField NotPromoted (noLoc s')) - ([HsValArg t1', HsValArg t2'] ++ tys') - } - - UInfixT t1 s t2 - -> do { t2' <- cvtType t2 - ; t <- cvtOpAppT t1 s t2' - ; mk_apps (unLoc t) tys' - } -- Note [Converting UInfix] - - ParensT t - -> do { t' <- cvtType t - ; mk_apps (HsParTy noExtField t') tys' - } - - PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm')) - tys' } - -- Promoted data constructor; hence cName - - PromotedTupleT n - | n == 1 - -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) - | Just normals <- m_normals - , normals `lengthIs` n -- Saturated - -> returnL (HsExplicitTupleTy noExtField normals) - | otherwise - -> mk_apps - (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n)))) - tys' - - PromotedNilT - -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys' - - PromotedConsT -- See Note [Representing concrete syntax in types] - -- in Language.Haskell.TH.Syntax - | Just normals <- m_normals - , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals - -> do - returnL (HsExplicitListTy noExtField ip (ty1:tys2)) - | otherwise - -> mk_apps - (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon))) - tys' - - StarT - -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) - tys' - - ConstraintT - -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon))) - tys' - - EqualityT - | Just normals <- m_normals - , [x',y'] <- normals -> - let px = parenthesizeHsType opPrec x' - py = parenthesizeHsType opPrec y' - in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py) - -- The long-term goal is to remove the above case entirely and - -- subsume it under the case for InfixT. See #15815, comment:6, - -- for more details. - - | otherwise -> - mk_apps (HsTyVar noExtField NotPromoted - (noLoc eqTyCon_RDR)) tys' - ImplicitParamT n t - -> do { n' <- wrapL $ ipName n - ; t' <- cvtType t - ; returnL (HsIParamTy noExtField n' t') - } - - _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) - } - --- | Constructs an application of a type to arguments passed in a list. -mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) -mk_apps head_ty type_args = do - head_ty' <- returnL head_ty - -- We must parenthesize the function type in case of an explicit - -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there - -- _must_ be parentheses around `Maybe :: Type -> Type`. - let phead_ty :: LHsType GhcPs - phead_ty = parenthesizeHsType sigPrec head_ty' - - go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) - go [] = pure head_ty' - go (arg:args) = - case arg of - HsValArg ty -> do p_ty <- add_parens ty - mk_apps (HsAppTy noExtField phead_ty p_ty) args - HsTypeArg l ki -> do p_ki <- add_parens ki - mk_apps (HsAppKindTy l phead_ty p_ki) args - HsArgPar _ -> mk_apps (HsParTy noExtField phead_ty) args - - go type_args - where - -- See Note [Adding parens for splices] - add_parens lt@(dL->L _ t) - | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) - | otherwise = return lt - -wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs -wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty -wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki -wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized - --- --------------------------------------------------------------------- --- Note [Adding parens for splices] -{- -The hsSyn representation of parsed source explicitly contains all the original -parens, as written in the source. - -When a Template Haskell (TH) splice is evaluated, the original splice is first -renamed and type checked and then finally converted to core in DsMeta. This core -is then run in the TH engine, and the result comes back as a TH AST. - -In the process, all parens are stripped out, as they are not needed. - -This Convert module then converts the TH AST back to hsSyn AST. - -In order to pretty-print this hsSyn AST, parens need to be adde back at certain -points so that the code is readable with its original meaning. - -So scattered through Convert.hs are various points where parens are added. - -See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289 --} --- --------------------------------------------------------------------- - --- | Constructs an arrow type with a specified return type -mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs) -mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL - where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs) - go arg ret_ty = do { ret_ty_l <- returnL ret_ty - ; return (HsFunTy noExtField arg ret_ty_l) } - -split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) -split_ty_app ty = go ty [] - where - go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') } - go (AppKindT ty ki) as' = do { ki' <- cvtKind ki - ; go ty (HsTypeArg noSrcSpan ki':as') } - go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } - go f as = return (f,as) - -cvtTyLit :: TH.TyLit -> HsTyLit -cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i -cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) - -{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator -application @x `op` y@. The produced tree of infix types will be right-biased, -provided @y@ is. - -See the @cvtOpApp@ documentation for how this function works. --} -cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs) -cvtOpAppT (UInfixT x op2 y) op1 z - = do { l <- cvtOpAppT y op1 z - ; cvtOpAppT x op2 l } -cvtOpAppT x op y - = do { op' <- tconNameL op - ; x' <- cvtType x - ; returnL (mkHsOpTy x' op' y) } - -cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) -cvtKind = cvtTypeKind "kind" - --- | Convert Maybe Kind to a type family result signature. Used with data --- families where naming of the result is not possible (thus only kind or no --- signature is possible). -cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind - -> CvtM (LFamilyResultSig GhcPs) -cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExtField) -cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki - ; returnL (Hs.KindSig noExtField ki') } - --- | Convert type family result signature. Used with both open and closed type --- families. -cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs) -cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExtField) -cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki - ; returnL (Hs.KindSig noExtField ki') } -cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr - ; returnL (Hs.TyVarSig noExtField tv) } - --- | Convert injectivity annotation of a type family. -cvtInjectivityAnnotation :: TH.InjectivityAnn - -> CvtM (Hs.LInjectivityAnn GhcPs) -cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) - = do { annLHS' <- tNameL annLHS - ; annRHS' <- mapM tNameL annRHS - ; returnL (Hs.InjectivityAnn annLHS' annRHS') } - -cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs) --- pattern synonym types are of peculiar shapes, which is why we treat --- them separately from regular types; --- see Note [Pattern synonym type signatures and Template Haskell] -cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) - | null exis, null provs = cvtType (ForallT univs reqs ty) - | null univs, null reqs = do { l <- getL - ; ty' <- cvtType (ForallT exis provs ty) - ; return $ cL l (HsQualTy { hst_ctxt = cL l [] - , hst_xqual = noExtField - , hst_body = ty' }) } - | null reqs = do { l <- getL - ; univs' <- hsQTvExplicit <$> cvtTvs univs - ; ty' <- cvtType (ForallT exis provs ty) - ; let forTy = HsForAllTy - { hst_fvf = ForallInvis - , hst_bndrs = univs' - , hst_xforall = noExtField - , hst_body = cL l cxtTy } - cxtTy = HsQualTy { hst_ctxt = cL l [] - , hst_xqual = noExtField - , hst_body = ty' } - ; return $ cL l forTy } - | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty)) -cvtPatSynSigTy ty = cvtType ty - ------------------------------------------------------------ -cvtFixity :: TH.Fixity -> Hs.Fixity -cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir) - where - cvt_dir TH.InfixL = Hs.InfixL - cvt_dir TH.InfixR = Hs.InfixR - cvt_dir TH.InfixN = Hs.InfixN - ------------------------------------------------------------ - - ------------------------------------------------------------ --- some useful things - -overloadedLit :: Lit -> Bool --- True for literals that Haskell treats as overloaded -overloadedLit (IntegerL _) = True -overloadedLit (RationalL _) = True -overloadedLit _ = False - --- Checks that are performed when converting unboxed sum expressions and --- patterns alike. -unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM () -unboxedSumChecks alt arity - | alt > arity - = failWith $ text "Sum alternative" <+> text (show alt) - <+> text "exceeds its arity," <+> text (show arity) - | alt <= 0 - = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt) - , nest 2 $ text "Sum alternatives must start from 1" ] - | arity < 2 - = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity) - , nest 2 $ text "Sums must have an arity of at least 2" ] - | otherwise - = return () - --- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the --- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' --- using the provided 'LHsQTyVars' and 'LHsType'. -mkHsForAllTy :: [TH.TyVarBndr] - -- ^ The original Template Haskell type variable binders - -> SrcSpan - -- ^ The location of the returned 'LHsType' if it needs an - -- explicit forall - -> ForallVisFlag - -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@) - -- or invisible (e.g., @forall a.@) - -> LHsQTyVars GhcPs - -- ^ The converted type variable binders - -> LHsType GhcPs - -- ^ The converted rho type - -> LHsType GhcPs - -- ^ The complete type, quantified with a forall if necessary -mkHsForAllTy tvs loc fvf tvs' rho_ty - | null tvs = rho_ty - | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf - , hst_bndrs = hsQTvExplicit tvs' - , hst_xforall = noExtField - , hst_body = rho_ty } - --- | If passed an empty 'TH.Cxt', this simply returns the third argument --- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided --- 'LHsContext' and 'LHsType'. - --- It's important that we don't build an HsQualTy if the context is empty, --- as the pretty-printer for HsType _always_ prints contexts, even if --- they're empty. See #13183. -mkHsQualTy :: TH.Cxt - -- ^ The original Template Haskell context - -> SrcSpan - -- ^ The location of the returned 'LHsType' if it needs an - -- explicit context - -> LHsContext GhcPs - -- ^ The converted context - -> LHsType GhcPs - -- ^ The converted tau type - -> LHsType GhcPs - -- ^ The complete type, qualified with a context if necessary -mkHsQualTy ctxt loc ctxt' ty - | null ctxt = ty - | otherwise = cL loc $ HsQualTy { hst_xqual = noExtField - , hst_ctxt = ctxt' - , hst_body = ty } - --------------------------------------------------------------------- --- Turning Name back into RdrName --------------------------------------------------------------------- - --- variable names -vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) -vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName - --- Variable names -vNameL n = wrapL (vName n) -vName n = cvtName OccName.varName n - --- Constructor function names; this is Haskell source, hence srcDataName -cNameL n = wrapL (cName n) -cName n = cvtName OccName.dataName n - --- Variable *or* constructor names; check by looking at the first char -vcNameL n = wrapL (vcName n) -vcName n = if isVarName n then vName n else cName n - --- Type variable names -tNameL n = wrapL (tName n) -tName n = cvtName OccName.tvName n - --- Type Constructor names -tconNameL n = wrapL (tconName n) -tconName n = cvtName OccName.tcClsName n - -ipName :: String -> CvtM HsIPName -ipName n - = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n)) - ; return (HsIPName (fsLit n)) } - -cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName -cvtName ctxt_ns (TH.Name occ flavour) - | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) - | otherwise - = do { loc <- getL - ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour - ; force rdr_name - ; return rdr_name } - where - occ_str = TH.occString occ - -okOcc :: OccName.NameSpace -> String -> Bool -okOcc ns str - | OccName.isVarNameSpace ns = okVarOcc str - | OccName.isDataConNameSpace ns = okConOcc str - | otherwise = okTcOcc str - --- Determine the name space of a name in a type --- -isVarName :: TH.Name -> Bool -isVarName (TH.Name occ _) - = case TH.occString occ of - "" -> False - (c:_) -> startsVarId c || startsVarSym c - -badOcc :: OccName.NameSpace -> String -> SDoc -badOcc ctxt_ns occ - = text "Illegal" <+> pprNameSpace ctxt_ns - <+> text "name:" <+> quotes (text occ) - -thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName --- This turns a TH Name into a RdrName; used for both binders and occurrences --- See Note [Binders in Template Haskell] --- The passed-in name space tells what the context is expecting; --- use it unless the TH name knows what name-space it comes --- from, in which case use the latter --- --- We pass in a SrcSpan (gotten from the monad) because this function --- is used for *binders* and if we make an Exact Name we want it --- to have a binding site inside it. (cf #5434) --- --- ToDo: we may generate silly RdrNames, by passing a name space --- that doesn't match the string, like VarName ":+", --- which will give confusing error messages later --- --- The strict applications ensure that any buried exceptions get forced -thRdrName loc ctxt_ns th_occ th_name - = case th_name of - TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod - TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ - TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc) - TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc) - TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name - | otherwise -> mkRdrUnqual $! occ - -- We check for built-in syntax here, because the TH - -- user might have written a (NameS "(,,)"), for example - where - occ :: OccName.OccName - occ = mk_occ ctxt_ns th_occ - --- Return an unqualified exact RdrName if we're dealing with built-in syntax. --- See #13776. -thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName -thOrigRdrName occ th_ns pkg mod = - let occ' = mk_occ (mk_ghc_ns th_ns) occ - in case isBuiltInOcc_maybe occ' of - Just name -> nameRdrName name - Nothing -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ' - -thRdrNameGuesses :: TH.Name -> [RdrName] -thRdrNameGuesses (TH.Name occ flavour) - -- This special case for NameG ensures that we don't generate duplicates in the output list - | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod] - | otherwise = [ thRdrName noSrcSpan gns occ_str flavour - | gns <- guessed_nss] - where - -- guessed_ns are the name spaces guessed from looking at the TH name - guessed_nss - | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] - | otherwise = [OccName.varName, OccName.tvName] - occ_str = TH.occString occ - --- The packing and unpacking is rather turgid :-( -mk_occ :: OccName.NameSpace -> String -> OccName.OccName -mk_occ ns occ = OccName.mkOccName ns occ - -mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace -mk_ghc_ns TH.DataName = OccName.dataName -mk_ghc_ns TH.TcClsName = OccName.tcClsName -mk_ghc_ns TH.VarName = OccName.varName - -mk_mod :: TH.ModName -> ModuleName -mk_mod mod = mkModuleName (TH.modString mod) - -mk_pkg :: TH.PkgName -> UnitId -mk_pkg pkg = stringToUnitId (TH.pkgString pkg) - -mk_uniq :: Int -> Unique -mk_uniq u = mkUniqueGrimily u - -{- -Note [Binders in Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this TH term construction: - do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name - ; x2 <- TH.newName "x" -- Builds a NameU - ; x3 <- TH.newName "x" - - ; let x = mkName "x" -- mkName :: String -> TH.Name - -- Builds a NameS - - ; return (LamE (..pattern [x1,x2]..) $ - LamE (VarPat x3) $ - ..tuple (x1,x2,x3,x)) } - -It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) - -a) We don't want to complain about "x" being bound twice in - the pattern [x1,x2] -b) We don't want x3 to shadow the x1,x2 -c) We *do* want 'x' (dynamically bound with mkName) to bind - to the innermost binding of "x", namely x3. -d) When pretty printing, we want to print a unique with x1,x2 - etc, else they'll all print as "x" which isn't very helpful - -When we convert all this to HsSyn, the TH.Names are converted with -thRdrName. To achieve (b) we want the binders to be Exact RdrNames. -Achieving (a) is a bit awkward, because - - We must check for duplicate and shadowed names on Names, - not RdrNames, *after* renaming. - See Note [Collect binders only after renaming] in HsUtils - - - But to achieve (a) we must distinguish between the Exact - RdrNames arising from TH and the Unqual RdrNames that would - come from a user writing \[x,x] -> blah - -So in Convert.thRdrName we translate - TH Name RdrName - -------------------------------------------------------- - NameU (arising from newName) --> Exact (Name{ System }) - NameS (arising from mkName) --> Unqual - -Notice that the NameUs generate *System* Names. Then, when -figuring out shadowing and duplicates, we can filter out -System Names. - -This use of System Names fits with other uses of System Names, eg for -temporary variables "a". Since there are lots of things called "a" we -usually want to print the name with the unique, and that is indeed -the way System Names are printed. - -There's a small complication of course; see Note [Looking up Exact -RdrNames] in RnEnv. --} - -{- -Note [Pattern synonym type signatures and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In general, the type signature of a pattern synonym - - pattern P x1 x2 .. xn = - -is of the form - - forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t - -with the following parts: - - 1) the (possibly empty lists of) universally quantified type - variables `univs` and required constraints `reqs` on them. - 2) the (possibly empty lists of) existentially quantified type - variables `exis` and the provided constraints `provs` on them. - 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1, - x2, .., xn, respectively - 4) the type `t` of , mentioning only universals from `univs`. - -Due to the two forall quantifiers and constraint contexts (either of -which might be empty), pattern synonym type signatures are treated -specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and -`typecheck/TcSplice.hs`: - - (a) When desugaring a pattern synonym from HsSyn to TH.Dec in - `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.: - - ForallT univs reqs (ForallT exis provs ty) - (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) - - (b) When converting pattern synonyms from TH.Dec to HsSyn in - `hsSyn/Convert.hs`, we convert their TH type signatures back to an - appropriate Haskell pattern synonym type of the form - - forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t - - where initial empty `univs` type variables or an empty `reqs` - constraint context are represented *explicitly* as `() =>`. - - (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always - return its *full* type, i.e.: - - ForallT univs reqs (ForallT exis provs ty) - (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t) - -The key point is to always represent a pattern synonym's *full* type -in cases (a) and (c) to make it clear which of the two forall -quantifiers and/or constraint contexts are specified, and which are -not. See GHC's user's guide on pattern synonyms for more information -about pattern synonym type signatures. - --} diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs deleted file mode 100644 index 4be761e3ac..0000000000 --- a/compiler/hsSyn/HsBinds.hs +++ /dev/null @@ -1,1310 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[HsBinds]{Abstract syntax: top-level bindings and signatures} - -Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module HsBinds where - -import GhcPrelude - -import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, - MatchGroup, pprFunBind, - GRHSs, pprPatBind ) -import {-# SOURCE #-} HsPat ( LPat ) - -import HsExtension -import HsTypes -import CoreSyn -import TcEvidence -import Type -import NameSet -import BasicTypes -import Outputable -import SrcLoc -import Var -import Bag -import FastString -import BooleanFormula (LBooleanFormula) -import DynFlags - -import Data.Data hiding ( Fixity ) -import Data.List hiding ( foldr ) -import Data.Ord - -{- -************************************************************************ -* * -\subsection{Bindings: @BindGroup@} -* * -************************************************************************ - -Global bindings (where clauses) --} - --- During renaming, we need bindings where the left-hand sides --- have been renamed but the right-hand sides have not. --- the ...LR datatypes are parametrized by two id types, --- one for the left and one for the right. --- Other than during renaming, these will be the same. - --- | Haskell Local Bindings -type HsLocalBinds id = HsLocalBindsLR id id - --- | Located Haskell local bindings -type LHsLocalBinds id = Located (HsLocalBinds id) - --- | Haskell Local Bindings with separate Left and Right identifier types --- --- Bindings in a 'let' expression --- or a 'where' clause -data HsLocalBindsLR idL idR - = HsValBinds - (XHsValBinds idL idR) - (HsValBindsLR idL idR) - -- ^ Haskell Value Bindings - - -- There should be no pattern synonyms in the HsValBindsLR - -- These are *local* (not top level) bindings - -- The parser accepts them, however, leaving the - -- renamer to report them - - | HsIPBinds - (XHsIPBinds idL idR) - (HsIPBinds idR) - -- ^ Haskell Implicit Parameter Bindings - - | EmptyLocalBinds (XEmptyLocalBinds idL idR) - -- ^ Empty Local Bindings - - | XHsLocalBindsLR - (XXHsLocalBindsLR idL idR) - -type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExtField -type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField -type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField -type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon - -type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) - - --- | Haskell Value Bindings -type HsValBinds id = HsValBindsLR id id - --- | Haskell Value bindings with separate Left and Right identifier types --- (not implicit parameters) --- Used for both top level and nested bindings --- May contain pattern synonym bindings -data HsValBindsLR idL idR - = -- | Value Bindings In - -- - -- Before renaming RHS; idR is always RdrName - -- Not dependency analysed - -- Recursive by default - ValBinds - (XValBinds idL idR) - (LHsBindsLR idL idR) [LSig idR] - - -- | Value Bindings Out - -- - -- After renaming RHS; idR can be Name or Id Dependency analysed, - -- later bindings in the list may depend on earlier ones. - | XValBindsLR - (XXValBindsLR idL idR) - --- --------------------------------------------------------------------- --- Deal with ValBindsOut - --- TODO: make this the only type for ValBinds -data NHsValBindsLR idL - = NValBinds - [(RecFlag, LHsBinds idL)] - [LSig GhcRn] - -type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField -type instance XXValBindsLR (GhcPass pL) (GhcPass pR) - = NHsValBindsLR (GhcPass pL) - --- --------------------------------------------------------------------- - --- | Located Haskell Binding -type LHsBind id = LHsBindLR id id - --- | Located Haskell Bindings -type LHsBinds id = LHsBindsLR id id - --- | Haskell Binding -type HsBind id = HsBindLR id id - --- | Located Haskell Bindings with separate Left and Right identifier types -type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) - --- | Located Haskell Binding with separate Left and Right identifier types -type LHsBindLR idL idR = Located (HsBindLR idL idR) - -{- Note [FunBind vs PatBind] - ~~~~~~~~~~~~~~~~~~~~~~~~~ -The distinction between FunBind and PatBind is a bit subtle. FunBind covers -patterns which resemble function bindings and simple variable bindings. - - f x = e - f !x = e - f = e - !x = e -- FunRhs has SrcStrict - x `f` y = e -- FunRhs has Infix - -The actual patterns and RHSs of a FunBind are encoding in fun_matches. -The m_ctxt field of each Match in fun_matches will be FunRhs and carries -two bits of information about the match, - - * The mc_fixity field on each Match describes the fixity of the - function binder in that match. E.g. this is legal: - f True False = e1 - True `f` True = e2 - - * The mc_strictness field is used /only/ for nullary FunBinds: ones - with one Match, which has no pats. For these, it describes whether - the match is decorated with a bang (e.g. `!x = e`). - -By contrast, PatBind represents data constructor patterns, as well as a few -other interesting cases. Namely, - - Just x = e - (x) = e - x :: Ty = e --} - --- | Haskell Binding with separate Left and Right id's -data HsBindLR idL idR - = -- | Function-like Binding - -- - -- FunBind is used for both functions @f x = e@ - -- and variables @f = \x -> e@ - -- and strict variables @!x = x + 1@ - -- - -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. - -- - -- Reason 2: Instance decls can only have FunBinds, which is convenient. - -- If you change this, you'll need to change e.g. rnMethodBinds - -- - -- But note that the form @f :: a->a = ...@ - -- parses as a pattern binding, just like - -- @(f :: a -> a) = ... @ - -- - -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their - -- 'MatchContext'. See Note [FunBind vs PatBind] for - -- details about the relationship between FunBind and PatBind. - -- - -- 'ApiAnnotation.AnnKeywordId's - -- - -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches - -- - -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - FunBind { - - fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains - -- the locally-bound - -- free variables of this defn. - -- See Note [Bind free vars] - - fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr - - fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload - - fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of - -- the Id. Example: - -- - -- @ - -- f :: Int -> forall a. a -> a - -- f x y = y - -- @ - -- - -- Then the MatchGroup will have type (Int -> a' -> a') - -- (with a free type variable a'). The coercion will take - -- a CoreExpr of this type and convert it to a CoreExpr of - -- type Int -> forall a'. a' -> a' - -- Notice that the coercion captures the free a'. - - fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any - } - - -- | Pattern Binding - -- - -- The pattern is never a simple variable; - -- That case is done by FunBind. - -- See Note [FunBind vs PatBind] for details about the - -- relationship between FunBind and PatBind. - - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', - -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | PatBind { - pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] - pat_lhs :: LPat idL, - pat_rhs :: GRHSs idR (LHsExpr idR), - pat_ticks :: ([Tickish Id], [[Tickish Id]]) - -- ^ Ticks to put on the rhs, if any, and ticks to put on - -- the bound variables. - } - - -- | Variable Binding - -- - -- Dictionary binding and suchlike. - -- All VarBinds are introduced by the type checker - | VarBind { - var_ext :: XVarBind idL idR, - var_id :: IdP idL, - var_rhs :: LHsExpr idR, -- ^ Located only for consistency - var_inline :: Bool -- ^ True <=> inline this binding regardless - -- (used for implication constraints only) - } - - -- | Abstraction Bindings - | AbsBinds { -- Binds abstraction; TRANSLATION - abs_ext :: XAbsBinds idL idR, - abs_tvs :: [TyVar], - abs_ev_vars :: [EvVar], -- ^ Includes equality constraints - - -- | AbsBinds only gets used when idL = idR after renaming, - -- but these need to be idL's for the collect... code in HsUtil - -- to have the right type - abs_exports :: [ABExport idL], - - -- | Evidence bindings - -- Why a list? See TcInstDcls - -- Note [Typechecking plan for instance declarations] - abs_ev_binds :: [TcEvBinds], - - -- | Typechecked user bindings - abs_binds :: LHsBinds idL, - - abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] - } - - -- | Patterns Synonym Binding - | PatSynBind - (XPatSynBind idL idR) - (PatSynBind idL idR) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', - -- 'ApiAnnotation.AnnWhere' - -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | XHsBindsLR (XXHsBindsLR idL idR) - -data NPatBindTc = NPatBindTc { - pat_fvs :: NameSet, -- ^ Free variables - pat_rhs_ty :: Type -- ^ Type of the GRHSs - } deriving Data - -type instance XFunBind (GhcPass pL) GhcPs = NoExtField -type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables -type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables - -type instance XPatBind GhcPs (GhcPass pR) = NoExtField -type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables -type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc - -type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField -type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField -type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField -type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon - - - -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] - -- - -- Creates bindings for (polymorphic, overloaded) poly_f - -- in terms of monomorphic, non-overloaded mono_f - -- - -- Invariants: - -- 1. 'binds' binds mono_f - -- 2. ftvs is a subset of tvs - -- 3. ftvs includes all tyvars free in ds - -- - -- See Note [AbsBinds] - --- | Abtraction Bindings Export -data ABExport p - = ABE { abe_ext :: XABE p - , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id - , abe_mono :: IdP p - , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] - -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly - , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas - } - | XABExport (XXABExport p) - -type instance XABE (GhcPass p) = NoExtField -type instance XXABExport (GhcPass p) = NoExtCon - - --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' --- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, --- 'ApiAnnotation.AnnClose' @'}'@, - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Pattern Synonym binding -data PatSynBind idL idR - = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs. - -- See Note [Bind free vars] - psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym - psb_args :: HsPatSynDetails (Located (IdP idR)), - -- ^ Formal parameter names - psb_def :: LPat idR, -- ^ Right-hand side - psb_dir :: HsPatSynDir idR -- ^ Directionality - } - | XPatSynBind (XXPatSynBind idL idR) - -type instance XPSB (GhcPass idL) GhcPs = NoExtField -type instance XPSB (GhcPass idL) GhcRn = NameSet -type instance XPSB (GhcPass idL) GhcTc = NameSet - -type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExtCon - -{- -Note [AbsBinds] -~~~~~~~~~~~~~~~ -The AbsBinds constructor is used in the output of the type checker, to -record *typechecked* and *generalised* bindings. Specifically - - AbsBinds { abs_tvs = tvs - , abs_ev_vars = [d1,d2] - , abs_exports = [ABE { abe_poly = fp, abe_mono = fm - , abe_wrap = fwrap } - ABE { slly for g } ] - , abs_ev_binds = DBINDS - , abs_binds = BIND[fm,gm] } - -where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means - - fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ] - [ ; BIND[fm,gm] } ] - [ in fm ] - - gp = ...same again, with gm instead of fm - -The 'fwrap' is an impedence-matcher that typically does nothing; see -Note [ABExport wrapper]. - -This is a pretty bad translation, because it duplicates all the bindings. -So the desugarer tries to do a better job: - - fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of - (fm,gm) -> fm - ..ditto for gp.. - - tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND } - in (fm,gm) - -In general: - - * abs_tvs are the type variables over which the binding group is - generalised - * abs_ev_var are the evidence variables (usually dictionaries) - over which the binding group is generalised - * abs_binds are the monomorphic bindings - * abs_ex_binds are the evidence bindings that wrap the abs_binds - * abs_exports connects the monomorphic Ids bound by abs_binds - with the polymorphic Ids bound by the AbsBinds itself. - -For example, consider a module M, with this top-level binding, where -there is no type signature for M.reverse, - M.reverse [] = [] - M.reverse (x:xs) = M.reverse xs ++ [x] - -In Hindley-Milner, a recursive binding is typechecked with the -*recursive* uses being *monomorphic*. So after typechecking *and* -desugaring we will get something like this - - M.reverse :: forall a. [a] -> [a] - = /\a. letrec - reverse :: [a] -> [a] = \xs -> case xs of - [] -> [] - (x:xs) -> reverse xs ++ [x] - in reverse - -Notice that 'M.reverse' is polymorphic as expected, but there is a local -definition for plain 'reverse' which is *monomorphic*. The type variable -'a' scopes over the entire letrec. - -That's after desugaring. What about after type checking but before -desugaring? That's where AbsBinds comes in. It looks like this: - - AbsBinds { abs_tvs = [a] - , abs_ev_vars = [] - , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], - , abe_mono = reverse :: [a] -> [a]}] - , abs_ev_binds = {} - , abs_binds = { reverse :: [a] -> [a] - = \xs -> case xs of - [] -> [] - (x:xs) -> reverse xs ++ [x] } } - -Here, - - * abs_tvs says what type variables are abstracted over the binding - group, just 'a' in this case. - * abs_binds is the *monomorphic* bindings of the group - * abs_exports describes how to get the polymorphic Id 'M.reverse' - from the monomorphic one 'reverse' - -Notice that the *original* function (the polymorphic one you thought -you were defining) appears in the abe_poly field of the -abs_exports. The bindings in abs_binds are for fresh, local, Ids with -a *monomorphic* Id. - -If there is a group of mutually recursive (see Note [Polymorphic -recursion]) functions without type signatures, we get one AbsBinds -with the monomorphic versions of the bindings in abs_binds, and one -element of abe_exports for each variable bound in the mutually -recursive group. This is true even for pattern bindings. Example: - (f,g) = (\x -> x, f) -After type checking we get - AbsBinds { abs_tvs = [a] - , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a - , abe_mono = f :: a -> a } - , ABE { abe_poly = M.g :: forall a. a -> a - , abe_mono = g :: a -> a }] - , abs_binds = { (f,g) = (\x -> x, f) } - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - Rec { f x = ...(g ef)... - - ; g :: forall a. [a] -> [a] - ; g y = ...(f eg)... } - -These bindings /are/ mutually recursive (f calls g, and g calls f). -But we can use the type signature for g to break the recursion, -like this: - - 1. Add g :: forall a. [a] -> [a] to the type environment - - 2. Typecheck the definition of f, all by itself, - including generalising it to find its most general - type, say f :: forall b. b -> b -> [b] - - 3. Extend the type environment with that type for f - - 4. Typecheck the definition of g, all by itself, - checking that it has the type claimed by its signature - -Steps 2 and 4 each generate a separate AbsBinds, so we end -up with - Rec { AbsBinds { ...for f ... } - ; AbsBinds { ...for g ... } } - -This approach allows both f and to call each other -polymorphically, even though only g has a signature. - -We get an AbsBinds that encompasses multiple source-program -bindings only when - * Each binding in the group has at least one binder that - lacks a user type signature - * The group forms a strongly connected component - - -Note [The abs_sig field of AbsBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The abs_sig field supports a couple of special cases for bindings. -Consider - - x :: Num a => (# a, a #) - x = (# 3, 4 #) - -The general desugaring for AbsBinds would give - - x = /\a. \ ($dNum :: Num a) -> - letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in - xm - -But that has an illegal let-binding for an unboxed tuple. In this -case we'd prefer to generate the (more direct) - - x = /\ a. \ ($dNum :: Num a) -> - (# fromInteger $dNum 3, fromInteger $dNum 4 #) - -A similar thing happens with representation-polymorphic defns -(#11405): - - undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a - undef = error "undef" - -Again, the vanilla desugaring gives a local let-binding for a -representation-polymorphic (undefm :: a), which is illegal. But -again we can desugar without a let: - - undef = /\ a. \ (d:HasCallStack) -> error a d "undef" - -The abs_sig field supports this direct desugaring, with no local -let-bining. When abs_sig = True - - * the abs_binds is single FunBind - - * the abs_exports is a singleton - - * we have a complete type sig for binder - and hence the abs_binds is non-recursive - (it binds the mono_id but refers to the poly_id - -These properties are exploited in DsBinds.dsAbsBinds to -generate code without a let-binding. - -Note [ABExport wrapper] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (f,g) = (\x.x, \y.y) -This ultimately desugars to something like this: - tup :: forall a b. (a->a, b->b) - tup = /\a b. (\x:a.x, \y:b.y) - f :: forall a. a -> a - f = /\a. case tup a Any of - (fm::a->a,gm:Any->Any) -> fm - ...similarly for g... - -The abe_wrap field deals with impedance-matching between - (/\a b. case tup a b of { (f,g) -> f }) -and the thing we really want, which may have fewer type -variables. The action happens in TcBinds.mkExport. - -Note [Bind free vars] -~~~~~~~~~~~~~~~~~~~~~ -The bind_fvs field of FunBind and PatBind records the free variables -of the definition. It is used for the following purposes - -a) Dependency analysis prior to type checking - (see TcBinds.tc_group) - -b) Deciding whether we can do generalisation of the binding - (see TcBinds.decideGeneralisationPlan) - -c) Deciding whether the binding can be used in static forms - (see TcExpr.checkClosedInStaticForm for the HsStatic case and - TcBinds.isClosedBndrGroup). - -Specifically, - - * bind_fvs includes all free vars that are defined in this module - (including top-level things and lexically scoped type variables) - - * bind_fvs excludes imported vars; this is just to keep the set smaller - - * Before renaming, and after typechecking, the field is unused; - it's just an error thunk --} - -instance (idL ~ GhcPass pl, idR ~ GhcPass pr, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsLocalBindsLR idL idR) where - ppr (HsValBinds _ bs) = ppr bs - ppr (HsIPBinds _ bs) = ppr bs - ppr (EmptyLocalBinds _) = empty - ppr (XHsLocalBindsLR x) = ppr x - -instance (idL ~ GhcPass pl, idR ~ GhcPass pr, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsValBindsLR idL idR) where - ppr (ValBinds _ binds sigs) - = pprDeclList (pprLHsBindsForUser binds sigs) - - ppr (XValBindsLR (NValBinds sccs sigs)) - = getPprStyle $ \ sty -> - if debugStyle sty then -- Print with sccs showing - vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) - else - pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) - where - ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds - pp_rec Recursive = text "rec" - pp_rec NonRecursive = text "nonrec" - -pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc -pprLHsBinds binds - | isEmptyLHsBinds binds = empty - | otherwise = pprDeclList (map ppr (bagToList binds)) - -pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), - OutputableBndrId (GhcPass id2)) - => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] --- pprLHsBindsForUser is different to pprLHsBinds because --- a) No braces: 'let' and 'where' include a list of HsBindGroups --- and we don't want several groups of bindings each --- with braces around --- b) Sort by location before printing --- c) Include signatures -pprLHsBindsForUser binds sigs - = map snd (sort_by_loc decls) - where - - decls :: [(SrcSpan, SDoc)] - decls = [(loc, ppr sig) | L loc sig <- sigs] ++ - [(loc, ppr bind) | L loc bind <- bagToList binds] - - sort_by_loc decls = sortBy (comparing fst) decls - -pprDeclList :: [SDoc] -> SDoc -- Braces with a space --- Print a bunch of declarations --- One could choose { d1; d2; ... }, using 'sep' --- or d1 --- d2 --- .. --- using vcat --- At the moment we chose the latter --- Also we do the 'pprDeeperList' thing. -pprDeclList ds = pprDeeperList vcat ds - ------------- -emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -emptyLocalBinds = EmptyLocalBinds noExtField - --- AZ:These functions do not seem to be used at all? -isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool -isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds -isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds -isEmptyLocalBindsTc (EmptyLocalBinds _) = True -isEmptyLocalBindsTc (XHsLocalBindsLR _) = True - -isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds -isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds -isEmptyLocalBindsPR (EmptyLocalBinds _) = True -isEmptyLocalBindsPR (XHsLocalBindsLR _) = True - -eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool -eqEmptyLocalBinds (EmptyLocalBinds _) = True -eqEmptyLocalBinds _ = False - -isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs -isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs - -emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) -emptyValBindsIn = ValBinds noExtField emptyBag [] -emptyValBindsOut = XValBindsLR (NValBinds [] []) - -emptyLHsBinds :: LHsBindsLR idL idR -emptyLHsBinds = emptyBag - -isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool -isEmptyLHsBinds = isEmptyBag - ------------- -plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) - -> HsValBinds(GhcPass a) -plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) - = ValBinds noExtField (ds1 `unionBags` ds2) (sigs1 ++ sigs2) -plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) - (XValBindsLR (NValBinds ds2 sigs2)) - = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) -plusHsValBinds _ _ - = panic "HsBinds.plusHsValBinds" - -instance (idL ~ GhcPass pl, idR ~ GhcPass pr, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsBindLR idL idR) where - ppr mbind = ppr_monobind mbind - -ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc - -ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) - = pprPatBind pat grhss -ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) - = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] -ppr_monobind (FunBind { fun_id = fun, - fun_co_fn = wrap, - fun_matches = matches, - fun_tick = ticks }) - = pprTicks empty (if null ticks then empty - else text "-- ticks = " <> ppr ticks) - $$ whenPprDebug (pprBndr LetBind (unLoc fun)) - $$ pprFunBind matches - $$ whenPprDebug (ppr wrap) -ppr_monobind (PatSynBind _ psb) = ppr psb -ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars - , abs_exports = exports, abs_binds = val_binds - , abs_ev_binds = ev_binds }) - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintTypecheckerElaboration dflags then - -- Show extra information (bug number: #10662) - hang (text "AbsBinds" <+> brackets (interpp'SP tyvars) - <+> brackets (interpp'SP dictvars)) - 2 $ braces $ vcat - [ text "Exports:" <+> - brackets (sep (punctuate comma (map ppr exports))) - , text "Exported types:" <+> - vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] - , text "Binds:" <+> pprLHsBinds val_binds - , text "Evidence:" <+> ppr ev_binds ] - else - pprLHsBinds val_binds -ppr_monobind (XHsBindsLR x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where - ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) - = vcat [ ppr gbl <+> text "<=" <+> ppr lcl - , nest 2 (pprTcSpecPrags prags) - , nest 2 (text "wrap:" <+> ppr wrap)] - ppr (XABExport x) = ppr x - -instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR, - Outputable (XXPatSynBind idL idR)) - => Outputable (PatSynBind idL idR) where - ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, - psb_dir = dir }) - = ppr_lhs <+> ppr_rhs - where - ppr_lhs = text "pattern" <+> ppr_details - ppr_simple syntax = syntax <+> ppr pat - - ppr_details = case details of - InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] - PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs) - RecCon vs -> pprPrefixOcc psyn - <> braces (sep (punctuate comma (map ppr vs))) - - ppr_rhs = case dir of - Unidirectional -> ppr_simple (text "<-") - ImplicitBidirectional -> ppr_simple equals - ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ - (nest 2 $ pprFunBind mg) - ppr (XPatSynBind x) = ppr x - -pprTicks :: SDoc -> SDoc -> SDoc --- Print stuff about ticks only when -dppr-debug is on, to avoid --- them appearing in error messages (from the desugarer); see # 3263 --- Also print ticks in dumpStyle, so that -ddump-hpc actually does --- something useful. -pprTicks pp_no_debug pp_when_debug - = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty - then pp_when_debug - else pp_no_debug) - -{- -************************************************************************ -* * - Implicit parameter bindings -* * -************************************************************************ --} - --- | Haskell Implicit Parameter Bindings -data HsIPBinds id - = IPBinds - (XIPBinds id) - [LIPBind id] - -- TcEvBinds -- Only in typechecker output; binds - -- -- uses of the implicit parameters - | XHsIPBinds (XXHsIPBinds id) - -type instance XIPBinds GhcPs = NoExtField -type instance XIPBinds GhcRn = NoExtField -type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the - -- implicit parameters - - -type instance XXHsIPBinds (GhcPass p) = NoExtCon - -isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool -isEmptyIPBindsPR (IPBinds _ is) = null is -isEmptyIPBindsPR (XHsIPBinds _) = True - -isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool -isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -isEmptyIPBindsTc (XHsIPBinds _) = True - --- | Located Implicit Parameter Binding -type LIPBind id = Located (IPBind id) --- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a --- list - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Implicit parameter bindings. --- --- These bindings start off as (Left "x") in the parser and stay --- that way until after type-checking when they are replaced with --- (Right d), where "d" is the name of the dictionary holding the --- evidence for the implicit parameter. --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' - --- For details on above see note [Api annotations] in ApiAnnotation -data IPBind id - = IPBind - (XCIPBind id) - (Either (Located HsIPName) (IdP id)) - (LHsExpr id) - | XIPBind (XXIPBind id) - -type instance XCIPBind (GhcPass p) = NoExtField -type instance XXIPBind (GhcPass p) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsIPBinds p) where - ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) - $$ whenPprDebug (ppr ds) - ppr (XHsIPBinds x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where - ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) - where name = case lr of - Left (L _ ip) -> pprBndr LetBind ip - Right id -> pprBndr LetBind id - ppr (XIPBind x) = ppr x - -{- -************************************************************************ -* * -\subsection{@Sig@: type signatures and value-modifying user pragmas} -* * -************************************************************************ - -It is convenient to lump ``value-modifying'' user-pragmas (e.g., -``specialise this function to these four types...'') in with type -signatures. Then all the machinery to move them into place, etc., -serves for both. --} - --- | Located Signature -type LSig pass = Located (Sig pass) - --- | Signatures and pragmas -data Sig pass - = -- | An ordinary type signature - -- - -- > f :: Num a => a -> a - -- - -- After renaming, this list of Names contains the named - -- wildcards brought into scope by this signature. For a signature - -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@ - -- untouched, and the named wildcard @_a@ is then replaced with - -- fresh meta vars in the type. Their names are stored in the type - -- signature that brought them into scope, in this third field to be - -- more specific. - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnComma' - - -- For details on above see note [Api annotations] in ApiAnnotation - TypeSig - (XTypeSig pass) - [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah - (LHsSigWcType pass) -- RHS of the signature; can have wildcards - - -- | A pattern synonym type signature - -- - -- > pattern Single :: () => (Show a) => a -> [a] - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall' - -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass) - -- P :: forall a b. Req => Prov => ty - - -- | A signature for a class method - -- False: ordinary class-method signature - -- True: generic-default class method signature - -- e.g. class C a where - -- op :: a -> a -- Ordinary - -- default op :: Eq a => a -> a -- Generic default - -- No wildcards allowed here - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', - -- 'ApiAnnotation.AnnDcolon' - | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass) - - -- | A type signature in generated code, notably the code - -- generated for record selectors. We simply record - -- the desired Id itself, replete with its name, type - -- and IdDetails. Otherwise it's just like a type - -- signature: there should be an accompanying binding - | IdSig (XIdSig pass) Id - - -- | An ordinary fixity declaration - -- - -- > infixl 8 *** - -- - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix', - -- 'ApiAnnotation.AnnVal' - - -- For details on above see note [Api annotations] in ApiAnnotation - | FixSig (XFixSig pass) (FixitySig pass) - - -- | An inline pragma - -- - -- > {#- INLINE f #-} - -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, - -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | InlineSig (XInlineSig pass) - (Located (IdP pass)) -- Function name - InlinePragma -- Never defaultInlinePragma - - -- | A specialisation pragma - -- - -- > {-# SPECIALISE f :: Int -> Int #-} - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, - -- 'ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, - -- 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (XSpecSig pass) - (Located (IdP pass)) -- Specialise a function or datatype ... - [LHsSigType pass] -- ... to these types - InlinePragma -- The pragma on SPECIALISE_INLINE form. - -- If it's just defaultInlinePragma, then we said - -- SPECIALISE, not SPECIALISE_INLINE - - -- | A specialisation pragma for instance declarations only - -- - -- > {-# SPECIALISE instance Eq [Int] #-} - -- - -- (Class tys); should be a specialisation of the - -- current instance declaration - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) - -- Note [Pragma source text] in BasicTypes - - -- | A minimal complete definition pragma - -- - -- > {-# MINIMAL a | (b, c | (d | e)) #-} - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | MinimalSig (XMinimalSig pass) - SourceText (LBooleanFormula (Located (IdP pass))) - -- Note [Pragma source text] in BasicTypes - - -- | A "set cost centre" pragma for declarations - -- - -- > {-# SCC funName #-} - -- - -- or - -- - -- > {-# SCC funName "cost_centre_name" #-} - - | SCCFunSig (XSCCFunSig pass) - SourceText -- Note [Pragma source text] in BasicTypes - (Located (IdP pass)) -- Function name - (Maybe (Located StringLiteral)) - -- | A complete match pragma - -- - -- > {-# COMPLETE C, D [:: T] #-} - -- - -- Used to inform the pattern match checker about additional - -- complete matchings which, for example, arise from pattern - -- synonym definitions. - | CompleteMatchSig (XCompleteMatchSig pass) - SourceText - (Located [Located (IdP pass)]) - (Maybe (Located (IdP pass))) - | XSig (XXSig pass) - -type instance XTypeSig (GhcPass p) = NoExtField -type instance XPatSynSig (GhcPass p) = NoExtField -type instance XClassOpSig (GhcPass p) = NoExtField -type instance XIdSig (GhcPass p) = NoExtField -type instance XFixSig (GhcPass p) = NoExtField -type instance XInlineSig (GhcPass p) = NoExtField -type instance XSpecSig (GhcPass p) = NoExtField -type instance XSpecInstSig (GhcPass p) = NoExtField -type instance XMinimalSig (GhcPass p) = NoExtField -type instance XSCCFunSig (GhcPass p) = NoExtField -type instance XCompleteMatchSig (GhcPass p) = NoExtField -type instance XXSig (GhcPass p) = NoExtCon - --- | Located Fixity Signature -type LFixitySig pass = Located (FixitySig pass) - --- | Fixity Signature -data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity - | XFixitySig (XXFixitySig pass) - -type instance XFixitySig (GhcPass p) = NoExtField -type instance XXFixitySig (GhcPass p) = NoExtCon - --- | Type checker Specialisation Pragmas --- --- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer -data TcSpecPrags - = IsDefaultMethod -- ^ Super-specialised: a default method should - -- be macro-expanded at every call site - | SpecPrags [LTcSpecPrag] - deriving Data - --- | Located Type checker Specification Pragmas -type LTcSpecPrag = Located TcSpecPrag - --- | Type checker Specification Pragma -data TcSpecPrag - = SpecPrag - Id - HsWrapper - InlinePragma - -- ^ The Id to be specialised, a wrapper that specialises the - -- polymorphic function, and inlining spec for the specialised function - deriving Data - -noSpecPrags :: TcSpecPrags -noSpecPrags = SpecPrags [] - -hasSpecPrags :: TcSpecPrags -> Bool -hasSpecPrags (SpecPrags ps) = not (null ps) -hasSpecPrags IsDefaultMethod = False - -isDefaultMethod :: TcSpecPrags -> Bool -isDefaultMethod IsDefaultMethod = True -isDefaultMethod (SpecPrags {}) = False - - -isFixityLSig :: LSig name -> Bool -isFixityLSig (L _ (FixSig {})) = True -isFixityLSig _ = False - -isTypeLSig :: LSig name -> Bool -- Type signatures -isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(ClassOpSig {})) = True -isTypeLSig (L _(IdSig {})) = True -isTypeLSig _ = False - -isSpecLSig :: LSig name -> Bool -isSpecLSig (L _(SpecSig {})) = True -isSpecLSig _ = False - -isSpecInstLSig :: LSig name -> Bool -isSpecInstLSig (L _ (SpecInstSig {})) = True -isSpecInstLSig _ = False - -isPragLSig :: LSig name -> Bool --- Identifies pragmas -isPragLSig (L _ (SpecSig {})) = True -isPragLSig (L _ (InlineSig {})) = True -isPragLSig (L _ (SCCFunSig {})) = True -isPragLSig (L _ (CompleteMatchSig {})) = True -isPragLSig _ = False - -isInlineLSig :: LSig name -> Bool --- Identifies inline pragmas -isInlineLSig (L _ (InlineSig {})) = True -isInlineLSig _ = False - -isMinimalLSig :: LSig name -> Bool -isMinimalLSig (L _ (MinimalSig {})) = True -isMinimalLSig _ = False - -isSCCFunSig :: LSig name -> Bool -isSCCFunSig (L _ (SCCFunSig {})) = True -isSCCFunSig _ = False - -isCompleteMatchSig :: LSig name -> Bool -isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True -isCompleteMatchSig _ = False - -hsSigDoc :: Sig name -> SDoc -hsSigDoc (TypeSig {}) = text "type signature" -hsSigDoc (PatSynSig {}) = text "pattern synonym signature" -hsSigDoc (ClassOpSig _ is_deflt _ _) - | is_deflt = text "default type signature" - | otherwise = text "class method signature" -hsSigDoc (IdSig {}) = text "id signature" -hsSigDoc (SpecSig {}) = text "SPECIALISE pragma" -hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" -hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" -hsSigDoc (FixSig {}) = text "fixity declaration" -hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" -hsSigDoc (SCCFunSig {}) = text "SCC pragma" -hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" -hsSigDoc (XSig {}) = text "XSIG TTG extension" - -{- -Check if signatures overlap; this is used when checking for duplicate -signatures. Since some of the signatures contain a list of names, testing for -equality is not enough -- we have to check if they overlap. --} - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where - ppr sig = ppr_sig sig - -ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc -ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (ClassOpSig _ is_deflt vars ty) - | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) - | otherwise = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) -ppr_sig (FixSig _ fix_sig) = ppr fix_sig -ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) - = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) - (interpp'SP ty) inl) - where - pragmaSrc = case spec of - NoUserInline -> "{-# SPECIALISE" - _ -> "{-# SPECIALISE_INLINE" -ppr_sig (InlineSig _ var inl) - = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl - <+> pprPrefixOcc (unLoc var)) -ppr_sig (SpecInstSig _ src ty) - = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty) -ppr_sig (MinimalSig _ src bf) - = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) -ppr_sig (PatSynSig _ names sig_ty) - = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) -ppr_sig (SCCFunSig _ src fn mlabel) - = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) -ppr_sig (CompleteMatchSig _ src cs mty) - = pragSrcBrackets src "{-# COMPLETE" - ((hsep (punctuate comma (map ppr (unLoc cs)))) - <+> opt_sig) - where - opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty -ppr_sig (XSig x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (FixitySig p) where - ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] - where - pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) - ppr (XFixitySig x) = ppr x - -pragBrackets :: SDoc -> SDoc -pragBrackets doc = text "{-#" <+> doc <+> text "#-}" - --- | Using SourceText in case the pragma was spelled differently or used mixed --- case -pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc -pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}" -pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" - -pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc -pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] - where - pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) - -pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc -pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty - where - pp_inl | isDefaultInlinePragma inl = empty - | otherwise = pprInline inl - -pprTcSpecPrags :: TcSpecPrags -> SDoc -pprTcSpecPrags IsDefaultMethod = text "" -pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) - -instance Outputable TcSpecPrag where - ppr (SpecPrag var _ inl) - = text "SPECIALIZE" <+> pprSpec var (text "") inl - -pprMinimalSig :: (OutputableBndr name) - => LBooleanFormula (Located name) -> SDoc -pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) - -{- -************************************************************************ -* * -\subsection[PatSynBind]{A pattern synonym definition} -* * -************************************************************************ --} - --- | Haskell Pattern Synonym Details -type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg] - --- See Note [Record PatSyn Fields] --- | Record Pattern Synonym Field -data RecordPatSynField a - = RecordPatSynField { - recordPatSynSelectorId :: a -- Selector name visible in rest of the file - , recordPatSynPatVar :: a - -- Filled in by renamer, the name used internally - -- by the pattern - } deriving (Data, Functor) - - - -{- -Note [Record PatSyn Fields] - -Consider the following two pattern synonyms. - -pattern P x y = ([x,True], [y,'v']) -pattern Q{ x, y } =([x,True], [y,'v']) - -In P, we just have two local binders, x and y. - -In Q, we have local binders but also top-level record selectors -x :: ([Bool], [Char]) -> Bool and similarly for y. - -It would make sense to support record-like syntax - -pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) - -when we have a different name for the local and top-level binder -the distinction between the two names clear - --} -instance Outputable a => Outputable (RecordPatSynField a) where - ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v - -instance Foldable RecordPatSynField where - foldMap f (RecordPatSynField { recordPatSynSelectorId = visible - , recordPatSynPatVar = hidden }) - = f visible `mappend` f hidden - -instance Traversable RecordPatSynField where - traverse f (RecordPatSynField { recordPatSynSelectorId =visible - , recordPatSynPatVar = hidden }) - = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id - , recordPatSynPatVar = pat_var }) - <$> f visible <*> f hidden - - --- | Haskell Pattern Synonym Direction -data HsPatSynDir id - = Unidirectional - | ImplicitBidirectional - | ExplicitBidirectional (MatchGroup id (LHsExpr id)) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs deleted file mode 100644 index 3cac82ed2f..0000000000 --- a/compiler/hsSyn/HsDecls.hs +++ /dev/null @@ -1,2417 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, - DeriveTraversable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} - --- | Abstract syntax of global declarations. --- --- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, --- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. -module HsDecls ( - -- * Toplevel declarations - HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, - HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour, - - -- ** Class or type declarations - TyClDecl(..), LTyClDecl, DataDeclRn(..), - TyClGroup(..), - tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, - isClassDecl, isDataDecl, isSynDecl, tcdName, - isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, - isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, - tyFamInstDeclName, tyFamInstDeclLName, - countTyClDecls, pprTyClDeclFlavour, - tyClDeclLName, tyClDeclTyVars, - hsDeclHasCusk, famDeclHasCusk, - FamilyDecl(..), LFamilyDecl, - - -- ** Instance declarations - InstDecl(..), LInstDecl, FamilyInfo(..), - TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, - TyFamDefltDecl, LTyFamDefltDecl, - DataFamInstDecl(..), LDataFamInstDecl, - pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS, - FamInstEqn, LFamInstEqn, FamEqn(..), - TyFamInstEqn, LTyFamInstEqn, HsTyPats, - LClsInstDecl, ClsInstDecl(..), - - -- ** Standalone deriving declarations - DerivDecl(..), LDerivDecl, - -- ** Deriving strategies - DerivStrategy(..), LDerivStrategy, - derivStrategyName, foldDerivStrategy, mapDerivStrategy, - -- ** @RULE@ declarations - LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), - RuleBndr(..),LRuleBndr, - collectRuleBndrSigTys, - flattenRuleDecls, pprFullRuleName, - -- ** @default@ declarations - DefaultDecl(..), LDefaultDecl, - -- ** Template haskell declaration splice - SpliceExplicitFlag(..), - SpliceDecl(..), LSpliceDecl, - -- ** Foreign function interface declarations - ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), - CImportSpec(..), - -- ** Data-constructor declarations - ConDecl(..), LConDecl, - HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta, - getConNames, getConArgs, - -- ** Document comments - DocDecl(..), LDocDecl, docDeclDoc, - -- ** Deprecations - WarnDecl(..), LWarnDecl, - WarnDecls(..), LWarnDecls, - -- ** Annotations - AnnDecl(..), LAnnDecl, - AnnProvenance(..), annProvenanceName_maybe, - -- ** Role annotations - RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName, - -- ** Injective type families - FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, - resultVariableName, - - -- * Grouping - HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls - - ) where - --- friends: -import GhcPrelude - -import {-# SOURCE #-} HsExpr( HsExpr, HsSplice, pprExpr, - pprSpliceDecl ) - -- Because Expr imports Decls via HsBracket - -import HsBinds -import HsTypes -import HsDoc -import TyCon -import BasicTypes -import Coercion -import ForeignCall -import HsExtension -import NameSet - --- others: -import Class -import Outputable -import Util -import SrcLoc -import Type - -import Bag -import Maybes -import Data.Data hiding (TyCon,Fixity, Infix) - -{- -************************************************************************ -* * -\subsection[HsDecl]{Declarations} -* * -************************************************************************ --} - -type LHsDecl p = Located (HsDecl p) - -- ^ When in a list this may have - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' - -- - --- For details on above see note [Api annotations] in ApiAnnotation - --- | A Haskell Declaration -data HsDecl p - = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration - | InstD (XInstD p) (InstDecl p) -- ^ Instance declaration - | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration - | ValD (XValD p) (HsBind p) -- ^ Value declaration - | SigD (XSigD p) (Sig p) -- ^ Signature declaration - | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration - | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration - | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration - | AnnD (XAnnD p) (AnnDecl p) -- ^ Annotation declaration - | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration - | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration - -- (Includes quasi-quotes) - | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration - | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration - | XHsDecl (XXHsDecl p) - -type instance XTyClD (GhcPass _) = NoExtField -type instance XInstD (GhcPass _) = NoExtField -type instance XDerivD (GhcPass _) = NoExtField -type instance XValD (GhcPass _) = NoExtField -type instance XSigD (GhcPass _) = NoExtField -type instance XDefD (GhcPass _) = NoExtField -type instance XForD (GhcPass _) = NoExtField -type instance XWarningD (GhcPass _) = NoExtField -type instance XAnnD (GhcPass _) = NoExtField -type instance XRuleD (GhcPass _) = NoExtField -type instance XSpliceD (GhcPass _) = NoExtField -type instance XDocD (GhcPass _) = NoExtField -type instance XRoleAnnotD (GhcPass _) = NoExtField -type instance XXHsDecl (GhcPass _) = NoExtCon - --- NB: all top-level fixity decls are contained EITHER --- EITHER SigDs --- OR in the ClassDecls in TyClDs --- --- The former covers --- a) data constructors --- b) class methods (but they can be also done in the --- signatures of class decls) --- c) imported functions (that have an IfacSig) --- d) top level decls --- --- The latter is for class methods only - --- | Haskell Group --- --- A 'HsDecl' is categorised into a 'HsGroup' before being --- fed to the renamer. -data HsGroup p - = HsGroup { - hs_ext :: XCHsGroup p, - hs_valds :: HsValBinds p, - hs_splcds :: [LSpliceDecl p], - - hs_tyclds :: [TyClGroup p], - -- A list of mutually-recursive groups; - -- This includes `InstDecl`s as well; - -- Parser generates a singleton list; - -- renamer does dependency analysis - - hs_derivds :: [LDerivDecl p], - - hs_fixds :: [LFixitySig p], - -- Snaffled out of both top-level fixity signatures, - -- and those in class declarations - - hs_defds :: [LDefaultDecl p], - hs_fords :: [LForeignDecl p], - hs_warnds :: [LWarnDecls p], - hs_annds :: [LAnnDecl p], - hs_ruleds :: [LRuleDecls p], - - hs_docs :: [LDocDecl] - } - | XHsGroup (XXHsGroup p) - -type instance XCHsGroup (GhcPass _) = NoExtField -type instance XXHsGroup (GhcPass _) = NoExtCon - - -emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) -emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } -emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } - -hsGroupInstDecls :: HsGroup id -> [LInstDecl id] -hsGroupInstDecls = (=<<) group_instds . hs_tyclds - -emptyGroup = HsGroup { hs_ext = noExtField, - hs_tyclds = [], - hs_derivds = [], - hs_fixds = [], hs_defds = [], hs_annds = [], - hs_fords = [], hs_warnds = [], hs_ruleds = [], - hs_valds = error "emptyGroup hs_valds: Can't happen", - hs_splcds = [], - hs_docs = [] } - -appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) - -> HsGroup (GhcPass p) -appendGroups - HsGroup { - hs_valds = val_groups1, - hs_splcds = spliceds1, - hs_tyclds = tyclds1, - hs_derivds = derivds1, - hs_fixds = fixds1, - hs_defds = defds1, - hs_annds = annds1, - hs_fords = fords1, - hs_warnds = warnds1, - hs_ruleds = rulds1, - hs_docs = docs1 } - HsGroup { - hs_valds = val_groups2, - hs_splcds = spliceds2, - hs_tyclds = tyclds2, - hs_derivds = derivds2, - hs_fixds = fixds2, - hs_defds = defds2, - hs_annds = annds2, - hs_fords = fords2, - hs_warnds = warnds2, - hs_ruleds = rulds2, - hs_docs = docs2 } - = - HsGroup { - hs_ext = noExtField, - hs_valds = val_groups1 `plusHsValBinds` val_groups2, - hs_splcds = spliceds1 ++ spliceds2, - hs_tyclds = tyclds1 ++ tyclds2, - hs_derivds = derivds1 ++ derivds2, - hs_fixds = fixds1 ++ fixds2, - hs_annds = annds1 ++ annds2, - hs_defds = defds1 ++ defds2, - hs_fords = fords1 ++ fords2, - hs_warnds = warnds1 ++ warnds2, - hs_ruleds = rulds1 ++ rulds2, - hs_docs = docs1 ++ docs2 } -appendGroups _ _ = panic "appendGroups" - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where - ppr (TyClD _ dcl) = ppr dcl - ppr (ValD _ binds) = ppr binds - ppr (DefD _ def) = ppr def - ppr (InstD _ inst) = ppr inst - ppr (DerivD _ deriv) = ppr deriv - ppr (ForD _ fd) = ppr fd - ppr (SigD _ sd) = ppr sd - ppr (RuleD _ rd) = ppr rd - ppr (WarningD _ wd) = ppr wd - ppr (AnnD _ ad) = ppr ad - ppr (SpliceD _ dd) = ppr dd - ppr (DocD _ doc) = ppr doc - ppr (RoleAnnotD _ ra) = ppr ra - ppr (XHsDecl x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where - ppr (HsGroup { hs_valds = val_decls, - hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = deprec_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls }) - = vcat_mb empty - [ppr_ds fix_decls, ppr_ds default_decls, - ppr_ds deprec_decls, ppr_ds ann_decls, - ppr_ds rule_decls, - if isEmptyValBinds val_decls - then Nothing - else Just (ppr val_decls), - ppr_ds (tyClGroupRoleDecls tycl_decls), - ppr_ds (tyClGroupTyClDecls tycl_decls), - ppr_ds (tyClGroupInstDecls tycl_decls), - ppr_ds deriv_decls, - ppr_ds foreign_decls] - where - ppr_ds :: Outputable a => [a] -> Maybe SDoc - ppr_ds [] = Nothing - ppr_ds ds = Just (vcat (map ppr ds)) - - vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc - -- Concatenate vertically with white-space between non-blanks - vcat_mb _ [] = empty - vcat_mb gap (Nothing : ds) = vcat_mb gap ds - vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds - ppr (XHsGroup x) = ppr x - --- | Located Splice Declaration -type LSpliceDecl pass = Located (SpliceDecl pass) - --- | Splice Declaration -data SpliceDecl p - = SpliceDecl -- Top level splice - (XSpliceDecl p) - (Located (HsSplice p)) - SpliceExplicitFlag - | XSpliceDecl (XXSpliceDecl p) - -type instance XSpliceDecl (GhcPass _) = NoExtField -type instance XXSpliceDecl (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (SpliceDecl p) where - ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f - ppr (XSpliceDecl x) = ppr x - -{- -************************************************************************ -* * - Type and class declarations -* * -************************************************************************ - -Note [The Naming story] -~~~~~~~~~~~~~~~~~~~~~~~ -Here is the story about the implicit names that go with type, class, -and instance decls. It's a bit tricky, so pay attention! - -"Implicit" (or "system") binders -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Each data type decl defines - a worker name for each constructor - to-T and from-T convertors - Each class decl defines - a tycon for the class - a data constructor for that tycon - the worker for that constructor - a selector for each superclass - -All have occurrence names that are derived uniquely from their parent -declaration. - -None of these get separate definitions in an interface file; they are -fully defined by the data or class decl. But they may *occur* in -interface files, of course. Any such occurrence must haul in the -relevant type or class decl. - -Plan of attack: - - Ensure they "point to" the parent data/class decl - when loading that decl from an interface file - (See RnHiFiles.getSysBinders) - - - When typechecking the decl, we build the implicit TyCons and Ids. - When doing so we look them up in the name cache (RnEnv.lookupSysName), - to ensure correct module and provenance is set - -These are the two places that we have to conjure up the magic derived -names. (The actual magic is in OccName.mkWorkerOcc, etc.) - -Default methods -~~~~~~~~~~~~~~~ - - Occurrence name is derived uniquely from the method name - E.g. $dmmax - - - If there is a default method name at all, it's recorded in - the ClassOpSig (in HsBinds), in the DefMethInfo field. - (DefMethInfo is defined in Class.hs) - -Source-code class decls and interface-code class decls are treated subtly -differently, which has given me a great deal of confusion over the years. -Here's the deal. (We distinguish the two cases because source-code decls -have (Just binds) in the tcdMeths field, whereas interface decls have Nothing. - -In *source-code* class declarations: - - - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName - This is done by RdrHsSyn.mkClassOpSigDM - - - The renamer renames it to a Name - - - During typechecking, we generate a binding for each $dm for - which there's a programmer-supplied default method: - class Foo a where - op1 :: - op2 :: - op1 = ... - We generate a binding for $dmop1 but not for $dmop2. - The Class for Foo has a Nothing for op2 and - a Just ($dm_op1, VanillaDM) for op1. - The Name for $dmop2 is simply discarded. - -In *interface-file* class declarations: - - When parsing, we see if there's an explicit programmer-supplied default method - because there's an '=' sign to indicate it: - class Foo a where - op1 = :: -- NB the '=' - op2 :: - We use this info to generate a DefMeth with a suitable RdrName for op1, - and a NoDefMeth for op2 - - The interface file has a separate definition for $dmop1, with unfolding etc. - - The renamer renames it to a Name. - - The renamer treats $dmop1 as a free variable of the declaration, so that - the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs) - This doesn't happen for source code class decls, because they *bind* the default method. - -Dictionary functions -~~~~~~~~~~~~~~~~~~~~ -Each instance declaration gives rise to one dictionary function binding. - -The type checker makes up new source-code instance declarations -(e.g. from 'deriving' or generic default methods --- see -TcInstDcls.tcInstDecls1). So we can't generate the names for -dictionary functions in advance (we don't know how many we need). - -On the other hand for interface-file instance declarations, the decl -specifies the name of the dictionary function, and it has a binding elsewhere -in the interface file: - instance {Eq Int} = dEqInt - dEqInt :: {Eq Int} - -So again we treat source code and interface file code slightly differently. - -Source code: - - Source code instance decls have a Nothing in the (Maybe name) field - (see data InstDecl below) - - - The typechecker makes up a Local name for the dict fun for any source-code - instance decl, whether it comes from a source-code instance decl, or whether - the instance decl is derived from some other construct (e.g. 'deriving'). - - - The occurrence name it chooses is derived from the instance decl (just for - documentation really) --- e.g. dNumInt. Two dict funs may share a common - occurrence name, but will have different uniques. E.g. - instance Foo [Int] where ... - instance Foo [Bool] where ... - These might both be dFooList - - - The CoreTidy phase externalises the name, and ensures the occurrence name is - unique (this isn't special to dict funs). So we'd get dFooList and dFooList1. - - - We can take this relaxed approach (changing the occurrence name later) - because dict fun Ids are not captured in a TyCon or Class (unlike default - methods, say). Instead, they are kept separately in the InstEnv. This - makes it easy to adjust them after compiling a module. (Once we've finished - compiling that module, they don't change any more.) - - -Interface file code: - - The instance decl gives the dict fun name, so the InstDecl has a (Just name) - in the (Maybe name) field. - - - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we - suck in the dfun binding --} - --- | Located Declaration of a Type or Class -type LTyClDecl pass = Located (TyClDecl pass) - --- | A type or class declaration. -data TyClDecl pass - = -- | @type/data family T :: *->*@ - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP', - -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow', - -- 'ApiAnnotation.AnnVbar' - - -- For details on above see note [Api annotations] in ApiAnnotation - FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } - - | -- | @type@ declaration - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnEqual', - - -- For details on above see note [Api annotations] in ApiAnnotation - SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs - , tcdLName :: Located (IdP pass) -- ^ Type constructor - , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an - -- associated type these - -- include outer binders - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdRhs :: LHsType pass } -- ^ RHS of type declaration - - | -- | @data@ declaration - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnFamily', - -- 'ApiAnnotation.AnnNewType', - -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon' - -- 'ApiAnnotation.AnnWhere', - - -- For details on above see note [Api annotations] in ApiAnnotation - DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs - , tcdLName :: Located (IdP pass) -- ^ Type constructor - , tcdTyVars :: LHsQTyVars pass -- ^ Type variables - -- See Note [TyVar binders for associated declarations] - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration - , tcdDataDefn :: HsDataDefn pass } - - | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs - tcdCtxt :: LHsContext pass, -- ^ Context... - tcdLName :: Located (IdP pass), -- ^ Name of the class - tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables - tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration - tcdFDs :: [LHsFunDep pass], -- ^ Functional deps - tcdSigs :: [LSig pass], -- ^ Methods' signatures - tcdMeths :: LHsBinds pass, -- ^ Default methods - tcdATs :: [LFamilyDecl pass], -- ^ Associated types; - tcdATDefs :: [LTyFamDefltDecl pass], -- ^ Associated type defaults - tcdDocs :: [LDocDecl] -- ^ Haddock docs - } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - -- - The tcdFDs will have 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnComma' - -- 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | XTyClDecl (XXTyClDecl pass) - -type LHsFunDep pass = Located (FunDep (Located (IdP pass))) - -data DataDeclRn = DataDeclRn - { tcdDataCusk :: Bool -- ^ does this have a CUSK? - -- See Note [CUSKs: complete user-supplied kind signatures] - , tcdFVs :: NameSet } - deriving Data - -{- Note [TyVar binders for associated decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For an /associated/ data, newtype, or type-family decl, the LHsQTyVars -/includes/ outer binders. For example - class T a where - data D a c - type F a b :: * - type F a b = a -> a -Here the data decl for 'D', and type-family decl for 'F', both include 'a' -in their LHsQTyVars (tcdTyVars and fdTyVars resp). - -Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars. - -The idea is that the associated type is really a top-level decl in its -own right. However we are careful to use the same name 'a', so that -we can match things up. - -c.f. Note [Associated type tyvar names] in Class.hs - Note [Family instance declaration binders] --} - -type instance XFamDecl (GhcPass _) = NoExtField - -type instance XSynDecl GhcPs = NoExtField -type instance XSynDecl GhcRn = NameSet -- FVs -type instance XSynDecl GhcTc = NameSet -- FVs - -type instance XDataDecl GhcPs = NoExtField -type instance XDataDecl GhcRn = DataDeclRn -type instance XDataDecl GhcTc = DataDeclRn - -type instance XClassDecl GhcPs = NoExtField -type instance XClassDecl GhcRn = NameSet -- FVs -type instance XClassDecl GhcTc = NameSet -- FVs - -type instance XXTyClDecl (GhcPass _) = NoExtCon - --- Simple classifiers for TyClDecl --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- | @True@ <=> argument is a @data@\/@newtype@ --- declaration. -isDataDecl :: TyClDecl pass -> Bool -isDataDecl (DataDecl {}) = True -isDataDecl _other = False - --- | type or type instance declaration -isSynDecl :: TyClDecl pass -> Bool -isSynDecl (SynDecl {}) = True -isSynDecl _other = False - --- | type class -isClassDecl :: TyClDecl pass -> Bool -isClassDecl (ClassDecl {}) = True -isClassDecl _ = False - --- | type/data family declaration -isFamilyDecl :: TyClDecl pass -> Bool -isFamilyDecl (FamDecl {}) = True -isFamilyDecl _other = False - --- | type family declaration -isTypeFamilyDecl :: TyClDecl pass -> Bool -isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of - OpenTypeFamily -> True - ClosedTypeFamily {} -> True - _ -> False -isTypeFamilyDecl _ = False - --- | open type family info -isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool -isOpenTypeFamilyInfo OpenTypeFamily = True -isOpenTypeFamilyInfo _ = False - --- | closed type family info -isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool -isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True -isClosedTypeFamilyInfo _ = False - --- | data family declaration -isDataFamilyDecl :: TyClDecl pass -> Bool -isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True -isDataFamilyDecl _other = False - --- Dealing with names - -tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p) -tyFamInstDeclName = unLoc . tyFamInstDeclLName - -tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p)) -tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = - (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) - = ln -tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec))) - = noExtCon nec -tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec - -tyClDeclLName :: TyClDecl pass -> Located (IdP pass) -tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln -tyClDeclLName decl = tcdLName decl - -tcdName :: TyClDecl pass -> (IdP pass) -tcdName = unLoc . tyClDeclLName - -tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass -tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs -tyClDeclTyVars d = tcdTyVars d - -countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) - -- class, synonym decls, data, newtype, family decls -countTyClDecls decls - = (count isClassDecl decls, - count isSynDecl decls, -- excluding... - count isDataTy decls, -- ...family... - count isNewTy decls, -- ...instances - count isFamilyDecl decls) - where - isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True - isDataTy _ = False - - isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True - isNewTy _ = False - --- | Does this declaration have a complete, user-supplied kind signature? --- See Note [CUSKs: complete user-supplied kind signatures] -hsDeclHasCusk - :: Bool -- True <=> the -XCUSKs extension is enabled - -> TyClDecl GhcRn - -> Bool -hsDeclHasCusk _cusks_enabled@False _ = False -hsDeclHasCusk cusks_enabled (FamDecl { tcdFam = fam_decl }) - = famDeclHasCusk cusks_enabled False fam_decl - -- False: this is not: an associated type of a class with no cusk -hsDeclHasCusk _cusks_enabled@True (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) - -- NB: Keep this synchronized with 'getInitialKind' - = hsTvbAllKinded tyvars && rhs_annotated rhs - where - rhs_annotated (L _ ty) = case ty of - HsParTy _ lty -> rhs_annotated lty - HsKindSig {} -> True - _ -> False -hsDeclHasCusk _cusks_enabled@True (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk -hsDeclHasCusk _cusks_enabled@True (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -hsDeclHasCusk _ (XTyClDecl nec) = noExtCon nec - --- Pretty-printing TyClDecl --- ~~~~~~~~~~~~~~~~~~~~~~~~ - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where - - ppr (FamDecl { tcdFam = decl }) = ppr decl - ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity - , tcdRhs = rhs }) - = hang (text "type" <+> - pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals) - 4 (ppr rhs) - - ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity - , tcdDataDefn = defn }) - = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn - - ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdFDs = fds, - tcdSigs = sigs, tcdMeths = methods, - tcdATs = ats, tcdATDefs = at_defs}) - | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part - = top_matter - - | otherwise -- Laid out - = vcat [ top_matter <+> text "where" - , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++ - map (pprTyFamDefltDecl . unLoc) at_defs ++ - pprLHsBindsForUser methods sigs) ] - where - top_matter = text "class" - <+> pp_vanilla_decl_head lclas tyvars fixity context - <+> pprFundeps (map unLoc fds) - - ppr (XTyClDecl x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (TyClGroup p) where - ppr (TyClGroup { group_tyclds = tyclds - , group_roles = roles - , group_instds = instds - } - ) - = ppr tyclds $$ - ppr roles $$ - ppr instds - ppr (XTyClGroup x) = ppr x - -pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p)) - => Located (IdP (GhcPass p)) - -> LHsQTyVars (GhcPass p) - -> LexicalFixity - -> LHsContext (GhcPass p) - -> SDoc -pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context - = hsep [pprLHsContext context, pp_tyvars tyvars] - where - pp_tyvars (varl:varsr) - | fixity == Infix && length varsr > 1 - = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) - , (ppr.unLoc) (head varsr), char ')' - , hsep (map (ppr.unLoc) (tail varsr))] - | fixity == Infix - = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) - , hsep (map (ppr.unLoc) varsr)] - | otherwise = hsep [ pprPrefixOcc (unLoc thing) - , hsep (map (ppr.unLoc) (varl:varsr))] - pp_tyvars [] = pprPrefixOcc (unLoc thing) -pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x - -pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc -pprTyClDeclFlavour (ClassDecl {}) = text "class" -pprTyClDeclFlavour (SynDecl {}) = text "type" -pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) - = pprFlavour info <+> text "family" -pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x}) - = ppr x -pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) - = ppr nd -pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x }) - = ppr x -pprTyClDeclFlavour (XTyClDecl x) = ppr x - - -{- Note [CUSKs: complete user-supplied kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We kind-check declarations differently if they have a complete, user-supplied -kind signature (CUSK). This is because we can safely generalise a CUSKed -declaration before checking all of the others, supporting polymorphic recursion. -See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy -and #9200 for lots of discussion of how we got here. - -The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default. -Under -XNoCUSKs, all declarations are treated as if they have no CUSK. -See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst - -PRINCIPLE: - a type declaration has a CUSK iff we could produce a separate kind signature - for it, just like a type signature for a function, - looking only at the header of the declaration. - -Examples: - * data T1 (a :: *->*) (b :: *) = .... - -- Has CUSK; equivalant to T1 :: (*->*) -> * -> * - - * data T2 a b = ... - -- No CUSK; we do not want to guess T2 :: * -> * -> * - -- because the full decl might be data T a b = MkT (a b) - - * data T3 (a :: k -> *) (b :: *) = ... - -- CUSK; equivalent to T3 :: (k -> *) -> * -> * - -- We lexically generalise over k to get - -- T3 :: forall k. (k -> *) -> * -> * - -- The generalisation is here is purely lexical, just like - -- f3 :: a -> a - -- means - -- f3 :: forall a. a -> a - - * data T4 (a :: j k) = ... - -- CUSK; equivalent to T4 :: j k -> * - -- which we lexically generalise to T4 :: forall j k. j k -> * - -- and then, if PolyKinds is on, we further generalise to - -- T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> * - -- Again this is exactly like what happens as the term level - -- when you write - -- f4 :: forall a b. a b -> Int - -NOTE THAT - * A CUSK does /not/ mean that everything about the kind signature is - fully specified by the user. Look at T4 and f4: we had do do kind - inference to figure out the kind-quantification. But in both cases - (T4 and f4) that inference is done looking /only/ at the header of T4 - (or signature for f4), not at the definition thereof. - - * The CUSK completely fixes the kind of the type constructor, forever. - - * The precise rules, for each declaration form, for whethher a declaration - has a CUSK are given in the user manual section "Complete user-supplied - kind signatures and polymorphic recursion". BUt they simply implement - PRINCIPLE above. - - * Open type families are interesting: - type family T5 a b :: * - There simply /is/ no accompanying declaration, so that info is all - we'll ever get. So we it has a CUSK by definition, and we default - any un-fixed kind variables to *. - - * Associated types are a bit tricker: - class C6 a where - type family T6 a b :: * - op :: a Int -> Int - Here C6 does not have a CUSK (in fact we ultimately discover that - a :: * -> *). And hence neither does T6, the associated family, - because we can't fix its kind until we have settled C6. Another - way to say it: unlike a top-level, we /may/ discover more about - a's kind from C6's definition. - - * A data definition with a top-level :: must explicitly bind all - kind variables to the right of the ::. See test - dependent/should_compile/KindLevels, which requires this - case. (Naturally, any kind variable mentioned before the :: should - not be bound after it.) - - This last point is much more debatable than the others; see - #15142 comment:22 - - Because this is fiddly to check, there is a field in the DataDeclRn - structure (included in a DataDecl after the renamer) that stores whether - or not the declaration has a CUSK. --} - - -{- ********************************************************************* -* * - TyClGroup - Strongly connected components of - type, class, instance, and role declarations -* * -********************************************************************* -} - -{- Note [TyClGroups and dependency analysis] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyClGroup represents a strongly connected components of type/class/instance -decls, together with the role annotations for the type/class declarations. - -The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order -sequence of strongly-connected components. - -Invariants - * The type and class declarations, group_tyclds, may depend on each - other, or earlier TyClGroups, but not on later ones - - * The role annotations, group_roles, are role-annotations for some or - all of the types and classes in group_tyclds (only). - - * The instance declarations, group_instds, may (and usually will) - depend on group_tyclds, or on earlier TyClGroups, but not on later - ones. - -See Note [Dependency analsis of type, class, and instance decls] -in RnSource for more info. --} - --- | Type or Class Group -data TyClGroup pass -- See Note [TyClGroups and dependency analysis] - = TyClGroup { group_ext :: XCTyClGroup pass - , group_tyclds :: [LTyClDecl pass] - , group_roles :: [LRoleAnnotDecl pass] - , group_instds :: [LInstDecl pass] } - | XTyClGroup (XXTyClGroup pass) - -type instance XCTyClGroup (GhcPass _) = NoExtField -type instance XXTyClGroup (GhcPass _) = NoExtCon - - -tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] -tyClGroupTyClDecls = concatMap group_tyclds - -tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] -tyClGroupInstDecls = concatMap group_instds - -tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] -tyClGroupRoleDecls = concatMap group_roles - - - -{- ********************************************************************* -* * - Data and type family declarations -* * -********************************************************************* -} - -{- Note [FamilyResultSig] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -This data type represents the return signature of a type family. Possible -values are: - - * NoSig - the user supplied no return signature: - type family Id a where ... - - * KindSig - the user supplied the return kind: - type family Id a :: * where ... - - * TyVarSig - user named the result with a type variable and possibly - provided a kind signature for that variable: - type family Id a = r where ... - type family Id a = (r :: *) where ... - - Naming result of a type family is required if we want to provide - injectivity annotation for a type family: - type family Id a = r | r -> a where ... - -See also: Note [Injectivity annotation] - -Note [Injectivity annotation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A user can declare a type family to be injective: - - type family Id a = r | r -> a where ... - - * The part after the "|" is called "injectivity annotation". - * "r -> a" part is called "injectivity condition"; at the moment terms - "injectivity annotation" and "injectivity condition" are synonymous - because we only allow a single injectivity condition. - * "r" is the "LHS of injectivity condition". LHS can only contain the - variable naming the result of a type family. - - * "a" is the "RHS of injectivity condition". RHS contains space-separated - type and kind variables representing the arguments of a type - family. Variables can be omitted if a type family is not injective in - these arguments. Example: - type family Foo a b c = d | d -> a c where ... - -Note that: - (a) naming of type family result is required to provide injectivity - annotation - (b) for associated types if the result was named then injectivity annotation - is mandatory. Otherwise result type variable is indistinguishable from - associated type default. - -It is possible that in the future this syntax will be extended to support -more complicated injectivity annotations. For example we could declare that -if we know the result of Plus and one of its arguments we can determine the -other argument: - - type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ... - -Here injectivity annotation would consist of two comma-separated injectivity -conditions. - -See also Note [Injective type families] in TyCon --} - --- | Located type Family Result Signature -type LFamilyResultSig pass = Located (FamilyResultSig pass) - --- | type Family Result Signature -data FamilyResultSig pass = -- see Note [FamilyResultSig] - NoSig (XNoSig pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : - - -- For details on above see note [Api annotations] in ApiAnnotation - - | KindSig (XCKindSig pass) (LHsKind pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnCloseP' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', - -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' - | XFamilyResultSig (XXFamilyResultSig pass) - - -- For details on above see note [Api annotations] in ApiAnnotation - -type instance XNoSig (GhcPass _) = NoExtField -type instance XCKindSig (GhcPass _) = NoExtField -type instance XTyVarSig (GhcPass _) = NoExtField -type instance XXFamilyResultSig (GhcPass _) = NoExtCon - - --- | Located type Family Declaration -type LFamilyDecl pass = Located (FamilyDecl pass) - --- | type Family Declaration -data FamilyDecl pass = FamilyDecl - { fdExt :: XCFamilyDecl pass - , fdInfo :: FamilyInfo pass -- type/data, closed/open - , fdLName :: Located (IdP pass) -- type constructor - , fdTyVars :: LHsQTyVars pass -- type variables - -- See Note [TyVar binders for associated declarations] - , fdFixity :: LexicalFixity -- Fixity used in the declaration - , fdResultSig :: LFamilyResultSig pass -- result signature - , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann - } - | XFamilyDecl (XXFamilyDecl pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', - -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', - -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP', - -- 'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow', - -- 'ApiAnnotation.AnnVbar' - - -- For details on above see note [Api annotations] in ApiAnnotation - -type instance XCFamilyDecl (GhcPass _) = NoExtField -type instance XXFamilyDecl (GhcPass _) = NoExtCon - - --- | Located Injectivity Annotation -type LInjectivityAnn pass = Located (InjectivityAnn pass) - --- | If the user supplied an injectivity annotation it is represented using --- InjectivityAnn. At the moment this is a single injectivity condition - see --- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity --- condition. `[Located name]` stores the RHS of injectivity condition. Example: --- --- type family Foo a b c = r | r -> a c where ... --- --- This will be represented as "InjectivityAnn `r` [`a`, `c`]" -data InjectivityAnn pass - = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)] - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' - - -- For details on above see note [Api annotations] in ApiAnnotation - -data FamilyInfo pass - = DataFamily - | OpenTypeFamily - -- | 'Nothing' if we're in an hs-boot file and the user - -- said "type family Foo x where .." - | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) - --- | Does this family declaration have a complete, user-supplied kind signature? --- See Note [CUSKs: complete user-supplied kind signatures] -famDeclHasCusk :: Bool -- ^ True <=> the -XCUSKs extension is enabled - -> Bool -- ^ True <=> this is an associated type family, - -- and the parent class has /no/ CUSK - -> FamilyDecl (GhcPass pass) - -> Bool -famDeclHasCusk _cusks_enabled@False _ _ = False -famDeclHasCusk _cusks_enabled@True assoc_with_no_cusk - (FamilyDecl { fdInfo = fam_info - , fdTyVars = tyvars - , fdResultSig = L _ resultSig }) - = case fam_info of - ClosedTypeFamily {} -> hsTvbAllKinded tyvars - && hasReturnKindSignature resultSig - _ -> not assoc_with_no_cusk - -- Un-associated open type/data families have CUSKs - -- Associated type families have CUSKs iff the parent class does - -famDeclHasCusk _ _ (XFamilyDecl nec) = noExtCon nec - --- | Does this family declaration have user-supplied return kind signature? -hasReturnKindSignature :: FamilyResultSig a -> Bool -hasReturnKindSignature (NoSig _) = False -hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False -hasReturnKindSignature _ = True - --- | Maybe return name of the result type variable -resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) -resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig -resultVariableName _ = Nothing - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (FamilyDecl p) where - ppr = pprFamilyDecl TopLevel - -pprFamilyDecl :: (OutputableBndrId (GhcPass p)) - => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc -pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = L _ result - , fdInjectivityAnn = mb_inj }) - = vcat [ pprFlavour info <+> pp_top_level <+> - pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> - pp_kind <+> pp_inj <+> pp_where - , nest 2 $ pp_eqns ] - where - pp_top_level = case top_level of - TopLevel -> text "family" - NotTopLevel -> empty - - pp_kind = case result of - NoSig _ -> empty - KindSig _ kind -> dcolon <+> ppr kind - TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr - XFamilyResultSig x -> ppr x - pp_inj = case mb_inj of - Just (L _ (InjectivityAnn lhs rhs)) -> - hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] - Nothing -> empty - (pp_where, pp_eqns) = case info of - ClosedTypeFamily mb_eqns -> - ( text "where" - , case mb_eqns of - Nothing -> text ".." - Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) - _ -> (empty, empty) -pprFamilyDecl _ (XFamilyDecl x) = ppr x - -pprFlavour :: FamilyInfo pass -> SDoc -pprFlavour DataFamily = text "data" -pprFlavour OpenTypeFamily = text "type" -pprFlavour (ClosedTypeFamily {}) = text "type" - -instance Outputable (FamilyInfo pass) where - ppr info = pprFlavour info <+> text "family" - - - -{- ********************************************************************* -* * - Data types and data constructors -* * -********************************************************************* -} - --- | Haskell Data type Definition -data HsDataDefn pass -- The payload of a data type defn - -- Used *both* for vanilla data declarations, - -- *and* for data family instances - = -- | Declares a data type or newtype, giving its constructors - -- @ - -- data/newtype T a = - -- data/newtype instance T [a] = - -- @ - HsDataDefn { dd_ext :: XCHsDataDefn pass, - dd_ND :: NewOrData, - dd_ctxt :: LHsContext pass, -- ^ Context - dd_cType :: Maybe (Located CType), - dd_kindSig:: Maybe (LHsKind pass), - -- ^ Optional kind signature. - -- - -- @(Just k)@ for a GADT-style @data@, - -- or @data instance@ decl, with explicit kind sig - -- - -- Always @Nothing@ for H98-syntax decls - - dd_cons :: [LConDecl pass], - -- ^ Data constructors - -- - -- For @data T a = T1 | T2 a@ - -- the 'LConDecl's all have 'ConDeclH98'. - -- For @data T a where { T1 :: T a }@ - -- the 'LConDecls' all have 'ConDeclGADT'. - - dd_derivs :: HsDeriving pass -- ^ Optional 'deriving' claues - - -- For details on above see note [Api annotations] in ApiAnnotation - } - | XHsDataDefn (XXHsDataDefn pass) - -type instance XCHsDataDefn (GhcPass _) = NoExtField -type instance XXHsDataDefn (GhcPass _) = NoExtCon - --- | Haskell Deriving clause -type HsDeriving pass = Located [LHsDerivingClause pass] - -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is - -- plural because one can specify multiple deriving clauses using the - -- @-XDerivingStrategies@ language extension. - -- - -- The list of 'LHsDerivingClause's corresponds to exactly what the user - -- requested to derive, in order. If no deriving clauses were specified, - -- the list is empty. - -type LHsDerivingClause pass = Located (HsDerivingClause pass) - --- | A single @deriving@ clause of a data declaration. --- --- - 'ApiAnnotation.AnnKeywordId' : --- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock', --- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', --- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -data HsDerivingClause pass - -- See Note [Deriving strategies] in TcDeriv - = HsDerivingClause - { deriv_clause_ext :: XCHsDerivingClause pass - , deriv_clause_strategy :: Maybe (LDerivStrategy pass) - -- ^ The user-specified strategy (if any) to use when deriving - -- 'deriv_clause_tys'. - , deriv_clause_tys :: Located [LHsSigType pass] - -- ^ The types to derive. - -- - -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, - -- we can mention type variables that aren't bound by the datatype, e.g. - -- - -- > data T b = ... deriving (C [a]) - -- - -- should produce a derived instance for @C [a] (T b)@. - } - | XHsDerivingClause (XXHsDerivingClause pass) - -type instance XCHsDerivingClause (GhcPass _) = NoExtField -type instance XXHsDerivingClause (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsDerivingClause p) where - ppr (HsDerivingClause { deriv_clause_strategy = dcs - , deriv_clause_tys = L _ dct }) - = hsep [ text "deriving" - , pp_strat_before - , pp_dct dct - , pp_strat_after ] - where - -- This complexity is to distinguish between - -- deriving Show - -- deriving (Show) - pp_dct [HsIB { hsib_body = ty }] - = ppr (parenthesizeHsType appPrec ty) - pp_dct _ = parens (interpp'SP dct) - - -- @via@ is unique in that in comes /after/ the class being derived, - -- so we must special-case it. - (pp_strat_before, pp_strat_after) = - case dcs of - Just (L _ via@ViaStrategy{}) -> (empty, ppr via) - _ -> (ppDerivStrategy dcs, empty) - ppr (XHsDerivingClause x) = ppr x - -data NewOrData - = NewType -- ^ @newtype Blah ...@ - | DataType -- ^ @data Blah ...@ - deriving( Eq, Data ) -- Needed because Demand derives Eq - --- | Convert a 'NewOrData' to a 'TyConFlavour' -newOrDataToFlavour :: NewOrData -> TyConFlavour -newOrDataToFlavour NewType = NewtypeFlavour -newOrDataToFlavour DataType = DataTypeFlavour - --- | Located data Constructor Declaration -type LConDecl pass = Located (ConDecl pass) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when - -- in a GADT constructor list - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | --- --- @ --- data T b = forall a. Eq a => MkT a b --- MkT :: forall b a. Eq a => MkT a b --- --- data T b where --- MkT1 :: Int -> T Int --- --- data T = Int `MkT` Int --- | MkT2 --- --- data T a where --- Int `MkT` Int :: T Int --- @ --- --- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', --- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow', --- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot' - --- For details on above see note [Api annotations] in ApiAnnotation - --- | data Constructor Declaration -data ConDecl pass - = ConDeclGADT - { con_g_ext :: XConDeclGADT pass - , con_names :: [Located (IdP pass)] - - -- The next four fields describe the type after the '::' - -- See Note [GADT abstract syntax] - -- The following field is Located to anchor API Annotations, - -- AnnForall and AnnDot. - , con_forall :: Located Bool -- ^ True <=> explicit forall - -- False => hsq_explicit is empty - , con_qvars :: LHsQTyVars pass - -- Whether or not there is an /explicit/ forall, we still - -- need to capture the implicitly-bound type/kind variables - - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon - , con_res_ty :: LHsType pass -- ^ Result type - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - - | ConDeclH98 - { con_ext :: XConDeclH98 pass - , con_name :: Located (IdP pass) - - , con_forall :: Located Bool - -- ^ True <=> explicit user-written forall - -- e.g. data T a = forall b. MkT b (b->a) - -- con_ex_tvs = {b} - -- False => con_ex_tvs is empty - , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } - | XConDecl (XXConDecl pass) - -type instance XConDeclGADT (GhcPass _) = NoExtField -type instance XConDeclH98 (GhcPass _) = NoExtField -type instance XXConDecl (GhcPass _) = NoExtCon - -{- Note [GADT abstract syntax] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a wrinkle in ConDeclGADT - -* For record syntax, it's all uniform. Given: - data T a where - K :: forall a. Ord a => { x :: [a], ... } -> T a - we make the a ConDeclGADT for K with - con_qvars = {a} - con_mb_cxt = Just [Ord a] - con_args = RecCon - con_res_ty = T a - - We need the RecCon before the reanmer, so we can find the record field - binders in HsUtils.hsConDeclsBinders. - -* However for a GADT constr declaration which is not a record, it can - be hard parse until we know operator fixities. Consider for example - C :: a :*: b -> a :*: b -> a :+: b - Initially this type will parse as - a :*: (b -> (a :*: (b -> (a :+: b)))) - so it's hard to split up the arguments until we've done the precedence - resolution (in the renamer). - - So: - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr - type into the res_ty for a ConDeclGADT for now, and use - PrefixCon [] - con_args = PrefixCon [] - con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) - - - In the renamer (RnSource.rnConDecl), we unravel it afer - operator fixities are sorted. So we generate. So we end - up with - con_args = PrefixCon [ a :*: b, a :*: b ] - con_res_ty = a :+: b --} - --- | Haskell data Constructor Declaration Details -type HsConDeclDetails pass - = HsConDetails (LBangType pass) (Located [LConDeclField pass]) - -getConNames :: ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))] -getConNames ConDeclH98 {con_name = name} = [name] -getConNames ConDeclGADT {con_names = names} = names -getConNames (XConDecl nec) = noExtCon nec - -getConArgs :: ConDecl pass -> HsConDeclDetails pass -getConArgs d = con_args d - -hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] -hsConDeclArgTys (PrefixCon tys) = tys -hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] -hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) - -hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] -hsConDeclTheta Nothing = [] -hsConDeclTheta (Just (L _ theta)) = theta - -pp_data_defn :: (OutputableBndrId (GhcPass p)) - => (LHsContext (GhcPass p) -> SDoc) -- Printing the header - -> HsDataDefn (GhcPass p) - -> SDoc -pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context - , dd_cType = mb_ct - , dd_kindSig = mb_sig - , dd_cons = condecls, dd_derivs = derivings }) - | null condecls - = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig - <+> pp_derivings derivings - - | otherwise - = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) - 2 (pp_condecls condecls $$ pp_derivings derivings) - where - pp_ct = case mb_ct of - Nothing -> empty - Just ct -> ppr ct - pp_sig = case mb_sig of - Nothing -> empty - Just kind -> dcolon <+> ppr kind - pp_derivings (L _ ds) = vcat (map ppr ds) -pp_data_defn _ (XHsDataDefn x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsDataDefn p) where - ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d - -instance Outputable NewOrData where - ppr NewType = text "newtype" - ppr DataType = text "data" - -pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc -pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax - = hang (text "where") 2 (vcat (map ppr cs)) -pp_condecls cs -- In H98 syntax - = equals <+> sep (punctuate (text " |") (map ppr cs)) - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where - ppr = pprConDecl - -pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> SDoc -pprConDecl (ConDeclH98 { con_name = L _ con - , con_ex_tvs = ex_tvs - , con_mb_cxt = mcxt - , con_args = args - , con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll ForallInvis ex_tvs cxt, ppr_details args] - where - ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] - ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con - : map (pprHsType . unLoc) tys) - ppr_details (RecCon fields) = pprPrefixOcc con - <+> pprConDeclFields (unLoc fields) - cxt = fromMaybe noLHsContext mcxt - -pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars - , con_mb_cxt = mcxt, con_args = args - , con_res_ty = res_ty, con_doc = doc }) - = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> (sep [pprHsForAll ForallInvis (hsq_explicit qvars) cxt, - ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) - where - get_args (PrefixCon args) = map ppr args - get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] - get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) - - cxt = fromMaybe noLHsContext mcxt - - ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) - ppr_arrow_chain [] = empty - -pprConDecl (XConDecl x) = ppr x - -ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc -ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) - -{- -************************************************************************ -* * - Instance declarations -* * -************************************************************************ - -Note [Type family instance declarations in HsSyn] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The data type FamEqn represents one equation of a type family instance. -Aside from the pass, it is also parameterised over another field, feqn_rhs. -feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType -(for type family instances). - -Type family instances also include associated type family default equations. -That is because a default for a type family looks like this: - - class C a where - type family F a b :: Type - type F c d = (c,d) -- Default instance - -The default declaration is really just a `type instance` declaration, but one -with particularly simple patterns: they must all be distinct type variables. -That's because we will instantiate it (in an instance declaration for `C`) if -we don't give an explicit instance for `F`. Note that the names of the -variables don't need to match those of the class: it really is like a -free-standing `type instance` declaration. --} - ------------------ Type synonym family instances ------------- - --- | Located Type Family Instance Equation -type LTyFamInstEqn pass = Located (TyFamInstEqn pass) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' - -- when in a list - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Haskell Type Patterns -type HsTyPats pass = [LHsTypeArg pass] - -{- Note [Family instance declaration binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The feqn_pats field of FamEqn (family instance equation) stores the LHS type -(and kind) patterns. Any type (and kind) variables contained -in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs -in FamInstEqn depending on whether or not an explicit forall is present. In -the case of an explicit forall, the hsib_vars only includes kind variables not -bound in the forall. Otherwise, all type (and kind) variables are bound in -the hsib_vars. In the latter case, note that in particular - -* The hsib_vars *includes* any anonymous wildcards. For example - type instance F a _ = a - The hsib_vars will be {a, _}. Remember that each separate wildcard - '_' gets its own unique. In this context wildcards behave just like - an ordinary type variable, only anonymous. - -* The hsib_vars *includes* type variables that are already in scope - - Eg class C s t where - type F t p :: * - instance C w (a,b) where - type F (a,b) x = x->a - The hsib_vars of the F decl are {a,b,x}, even though the F decl - is nested inside the 'instance' decl. - - However after the renamer, the uniques will match up: - instance C w7 (a8,b9) where - type F (a8,b9) x10 = x10->a8 - so that we can compare the type pattern in the 'instance' decl and - in the associated 'type' decl - -c.f. Note [TyVar binders for associated decls] --} - --- | Type Family Instance Equation -type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) - --- | Type family default declarations. --- A convenient synonym for 'TyFamInstDecl'. --- See @Note [Type family instance declarations in HsSyn]@. -type TyFamDefltDecl = TyFamInstDecl - --- | Located type family default declarations. -type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass) - --- | Located Type Family Instance Declaration -type LTyFamInstDecl pass = Located (TyFamInstDecl pass) - --- | Type Family Instance Declaration -newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnInstance', - - -- For details on above see note [Api annotations] in ApiAnnotation - ------------------ Data family instances ------------- - --- | Located Data Family Instance Declaration -type LDataFamInstDecl pass = Located (DataFamInstDecl pass) - --- | Data Family Instance Declaration -newtype DataFamInstDecl pass - = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', - -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', - -- 'ApiAnnotation.AnnDcolon' - -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - ------------------ Family instances (common types) ------------- - --- | Located Family Instance Equation -type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs) - --- | Family Instance Equation -type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs) - -- ^ Here, the @pats@ are type patterns (with kind and type bndrs). - -- See Note [Family instance declaration binders] - --- | Family Equation --- --- One equation in a type family instance declaration, data family instance --- declaration, or type family default. --- See Note [Type family instance declarations in HsSyn] --- See Note [Family instance declaration binders] -data FamEqn pass rhs - = FamEqn - { feqn_ext :: XCFamEqn pass rhs - , feqn_tycon :: Located (IdP pass) - , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars - , feqn_pats :: HsTyPats pass - , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration - , feqn_rhs :: rhs - } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' - | XFamEqn (XXFamEqn pass rhs) - - -- For details on above see note [Api annotations] in ApiAnnotation - -type instance XCFamEqn (GhcPass _) r = NoExtField -type instance XXFamEqn (GhcPass _) r = NoExtCon - ------------------ Class instances ------------- - --- | Located Class Instance Declaration -type LClsInstDecl pass = Located (ClsInstDecl pass) - --- | Class Instance Declaration -data ClsInstDecl pass - = ClsInstDecl - { cid_ext :: XCClsInstDecl pass - , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. - , cid_binds :: LHsBinds pass -- Class methods - , cid_sigs :: [LSig pass] -- User-supplied pragmatic info - , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances - , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances - , cid_overlap_mode :: Maybe (Located OverlapMode) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance', - -- 'ApiAnnotation.AnnWhere', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | XClsInstDecl (XXClsInstDecl pass) - -type instance XCClsInstDecl (GhcPass _) = NoExtField -type instance XXClsInstDecl (GhcPass _) = NoExtCon - ------------------ Instances of all kinds ------------- - --- | Located Instance Declaration -type LInstDecl pass = Located (InstDecl pass) - --- | Instance Declaration -data InstDecl pass -- Both class and family instances - = ClsInstD - { cid_d_ext :: XClsInstD pass - , cid_inst :: ClsInstDecl pass } - | DataFamInstD -- data family instance - { dfid_ext :: XDataFamInstD pass - , dfid_inst :: DataFamInstDecl pass } - | TyFamInstD -- type family instance - { tfid_ext :: XTyFamInstD pass - , tfid_inst :: TyFamInstDecl pass } - | XInstDecl (XXInstDecl pass) - -type instance XClsInstD (GhcPass _) = NoExtField -type instance XDataFamInstD (GhcPass _) = NoExtField -type instance XTyFamInstD (GhcPass _) = NoExtField -type instance XXInstDecl (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (TyFamInstDecl p) where - ppr = pprTyFamInstDecl TopLevel - -pprTyFamInstDecl :: (OutputableBndrId (GhcPass p)) - => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc -pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) - = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn - -ppr_instance_keyword :: TopLevelFlag -> SDoc -ppr_instance_keyword TopLevel = text "instance" -ppr_instance_keyword NotTopLevel = empty - -pprTyFamDefltDecl :: (OutputableBndrId (GhcPass p)) - => TyFamDefltDecl (GhcPass p) -> SDoc -pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel - -ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p)) - => TyFamInstEqn (GhcPass p) -> SDoc -ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon - , feqn_bndrs = bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = rhs }}) - = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs -ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x -ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DataFamInstDecl p) where - ppr = pprDataFamInstDecl TopLevel - -pprDataFamInstDecl :: (OutputableBndrId (GhcPass p)) - => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc -pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_tycon = L _ tycon - , feqn_bndrs = bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = defn }}}) - = pp_data_defn pp_hdr defn - where - pp_hdr ctxt = ppr_instance_keyword top_lvl - <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt - -- pp_data_defn pretty-prints the kind sig. See #14817. - -pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x))) - = ppr x -pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x)) - = ppr x - -pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc -pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) - = ppr nd -pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = XHsDataDefn x}}}) - = ppr x -pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) - = ppr x -pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) - = ppr x - -pprHsFamInstLHS :: (OutputableBndrId (GhcPass p)) - => IdP (GhcPass p) - -> Maybe [LHsTyVarBndr (GhcPass p)] - -> HsTyPats (GhcPass p) - -> LexicalFixity - -> LHsContext (GhcPass p) - -> SDoc -pprHsFamInstLHS thing bndrs typats fixity mb_ctxt - = hsep [ pprHsExplicitForAll ForallInvis bndrs - , pprLHsContext mb_ctxt - , pp_pats typats ] - where - pp_pats (patl:patr:pats) - | Infix <- fixity - = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in - case pats of - [] -> pp_op_app - _ -> hsep (parens pp_op_app : map ppr pats) - - pp_pats pats = hsep [ pprPrefixOcc thing - , hsep (map ppr pats)] - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (ClsInstDecl p) where - ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds - , cid_sigs = sigs, cid_tyfam_insts = ats - , cid_overlap_mode = mbOverlap - , cid_datafam_insts = adts }) - | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part - = top_matter - - | otherwise -- Laid out - = vcat [ top_matter <+> text "where" - , nest 2 $ pprDeclList $ - map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ - map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ - pprLHsBindsForUser binds sigs ] - where - top_matter = text "instance" <+> ppOverlapPragma mbOverlap - <+> ppr inst_ty - ppr (XClsInstDecl x) = ppr x - -ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p) - => Maybe (LDerivStrategy p) -> SDoc -ppDerivStrategy mb = - case mb of - Nothing -> empty - Just (L _ ds) -> ppr ds - -ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc -ppOverlapPragma mb = - case mb of - Nothing -> empty - Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" - Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" - Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" - Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" - Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" - where - maybe_stext NoSourceText alt = text alt - maybe_stext (SourceText src) _ = text src <+> text "#-}" - - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where - ppr (ClsInstD { cid_inst = decl }) = ppr decl - ppr (TyFamInstD { tfid_inst = decl }) = ppr decl - ppr (DataFamInstD { dfid_inst = decl }) = ppr decl - ppr (XInstDecl x) = ppr x - --- Extract the declarations of associated data types from an instance - -instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)] -instDeclDataFamInsts inst_decls - = concatMap do_one inst_decls - where - do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) - = map unLoc fam_insts - do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] - do_one (L _ (TyFamInstD {})) = [] - do_one (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec - do_one (L _ (XInstDecl nec)) = noExtCon nec - -{- -************************************************************************ -* * -\subsection[DerivDecl]{A stand-alone instance deriving declaration} -* * -************************************************************************ --} - --- | Located stand-alone 'deriving instance' declaration -type LDerivDecl pass = Located (DerivDecl pass) - --- | Stand-alone 'deriving instance' declaration -data DerivDecl pass = DerivDecl - { deriv_ext :: XCDerivDecl pass - , deriv_type :: LHsSigWcType pass - -- ^ The instance type to derive. - -- - -- It uses an 'LHsSigWcType' because the context is allowed to be a - -- single wildcard: - -- - -- > deriving instance _ => Eq (Foo a) - -- - -- Which signifies that the context should be inferred. - - -- See Note [Inferring the instance context] in TcDerivInfer. - - , deriv_strategy :: Maybe (LDerivStrategy pass) - , deriv_overlap_mode :: Maybe (Located OverlapMode) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', - -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', - -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - } - | XDerivDecl (XXDerivDecl pass) - -type instance XCDerivDecl (GhcPass _) = NoExtField -type instance XXDerivDecl (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DerivDecl p) where - ppr (DerivDecl { deriv_type = ty - , deriv_strategy = ds - , deriv_overlap_mode = o }) - = hsep [ text "deriving" - , ppDerivStrategy ds - , text "instance" - , ppOverlapPragma o - , ppr ty ] - ppr (XDerivDecl x) = ppr x - -{- -************************************************************************ -* * - Deriving strategies -* * -************************************************************************ --} - --- | A 'Located' 'DerivStrategy'. -type LDerivStrategy pass = Located (DerivStrategy pass) - --- | Which technique the user explicitly requested when deriving an instance. -data DerivStrategy pass - -- See Note [Deriving strategies] in TcDeriv - = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a - -- custom instance for the data type. This only works - -- for certain types that GHC knows about (e.g., 'Eq', - -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, - -- etc.) - | AnyclassStrategy -- ^ @-XDeriveAnyClass@ - | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ - | ViaStrategy (XViaStrategy pass) - -- ^ @-XDerivingVia@ - -type instance XViaStrategy GhcPs = LHsSigType GhcPs -type instance XViaStrategy GhcRn = LHsSigType GhcRn -type instance XViaStrategy GhcTc = Type - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DerivStrategy p) where - ppr StockStrategy = text "stock" - ppr AnyclassStrategy = text "anyclass" - ppr NewtypeStrategy = text "newtype" - ppr (ViaStrategy ty) = text "via" <+> ppr ty - --- | A short description of a @DerivStrategy'@. -derivStrategyName :: DerivStrategy a -> SDoc -derivStrategyName = text . go - where - go StockStrategy = "stock" - go AnyclassStrategy = "anyclass" - go NewtypeStrategy = "newtype" - go (ViaStrategy {}) = "via" - --- | Eliminate a 'DerivStrategy'. -foldDerivStrategy :: (p ~ GhcPass pass) - => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r -foldDerivStrategy other _ StockStrategy = other -foldDerivStrategy other _ AnyclassStrategy = other -foldDerivStrategy other _ NewtypeStrategy = other -foldDerivStrategy _ via (ViaStrategy t) = via t - --- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise, --- return the 'DerivStrategy' unchanged. -mapDerivStrategy :: (p ~ GhcPass pass) - => (XViaStrategy p -> XViaStrategy p) - -> DerivStrategy p -> DerivStrategy p -mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds - -{- -************************************************************************ -* * -\subsection[DefaultDecl]{A @default@ declaration} -* * -************************************************************************ - -There can only be one default declaration per module, but it is hard -for the parser to check that; we pass them all through in the abstract -syntax, and that restriction must be checked in the front end. --} - --- | Located Default Declaration -type LDefaultDecl pass = Located (DefaultDecl pass) - --- | Default Declaration -data DefaultDecl pass - = DefaultDecl (XCDefaultDecl pass) [LHsType pass] - -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | XDefaultDecl (XXDefaultDecl pass) - -type instance XCDefaultDecl (GhcPass _) = NoExtField -type instance XXDefaultDecl (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DefaultDecl p) where - ppr (DefaultDecl _ tys) - = text "default" <+> parens (interpp'SP tys) - ppr (XDefaultDecl x) = ppr x - -{- -************************************************************************ -* * -\subsection{Foreign function interface declaration} -* * -************************************************************************ --} - --- foreign declarations are distinguished as to whether they define or use a --- Haskell name --- --- * the Boolean value indicates whether the pre-standard deprecated syntax --- has been used - --- | Located Foreign Declaration -type LForeignDecl pass = Located (ForeignDecl pass) - --- | Foreign Declaration -data ForeignDecl pass - = ForeignImport - { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty - , fd_name :: Located (IdP pass) -- defines this name - , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_fi :: ForeignImport } - - | ForeignExport - { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty - , fd_name :: Located (IdP pass) -- uses this name - , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_fe :: ForeignExport } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', - -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', - -- 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | XForeignDecl (XXForeignDecl pass) - -{- - In both ForeignImport and ForeignExport: - sig_ty is the type given in the Haskell code - rep_ty is the representation for this type, i.e. with newtypes - coerced away and type functions evaluated. - Thus if the declaration is valid, then rep_ty will only use types - such as Int and IO that we know how to make foreign calls with. --} - -type instance XForeignImport GhcPs = NoExtField -type instance XForeignImport GhcRn = NoExtField -type instance XForeignImport GhcTc = Coercion - -type instance XForeignExport GhcPs = NoExtField -type instance XForeignExport GhcRn = NoExtField -type instance XForeignExport GhcTc = Coercion - -type instance XXForeignDecl (GhcPass _) = NoExtCon - --- Specification Of an imported external entity in dependence on the calling --- convention --- -data ForeignImport = -- import of a C entity - -- - -- * the two strings specifying a header file or library - -- may be empty, which indicates the absence of a - -- header or object specification (both are not used - -- in the case of `CWrapper' and when `CFunction' - -- has a dynamic target) - -- - -- * the calling convention is irrelevant for code - -- generation in the case of `CLabel', but is needed - -- for pretty printing - -- - -- * `Safety' is irrelevant for `CLabel' and `CWrapper' - -- - CImport (Located CCallConv) -- ccall or stdcall - (Located Safety) -- interruptible, safe or unsafe - (Maybe Header) -- name of C header - CImportSpec -- details of the C entity - (Located SourceText) -- original source text for - -- the C entity - deriving Data - --- details of an external C entity --- -data CImportSpec = CLabel CLabelString -- import address of a C label - | CFunction CCallTarget -- static or dynamic function - | CWrapper -- wrapper to expose closures - -- (former f.e.d.) - deriving Data - --- specification of an externally exported entity in dependence on the calling --- convention --- -data ForeignExport = CExport (Located CExportSpec) -- contains the calling - -- convention - (Located SourceText) -- original source text for - -- the C entity - deriving Data - --- pretty printing of foreign declarations --- - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (ForeignDecl p) where - ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) - = hang (text "foreign import" <+> ppr fimport <+> ppr n) - 2 (dcolon <+> ppr ty) - ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = - hang (text "foreign export" <+> ppr fexport <+> ppr n) - 2 (dcolon <+> ppr ty) - ppr (XForeignDecl x) = ppr x - -instance Outputable ForeignImport where - ppr (CImport cconv safety mHeader spec (L _ srcText)) = - ppr cconv <+> ppr safety - <+> pprWithSourceText srcText (pprCEntity spec "") - where - pp_hdr = case mHeader of - Nothing -> empty - Just (Header _ header) -> ftext header - - pprCEntity (CLabel lbl) _ = - doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = - if dqNeeded then doubleQuotes ce else empty - where - dqNeeded = (take 6 src == "static") - || isJust mHeader - || not isFun - || st /= NoSourceText - ce = - -- We may need to drop leading spaces first - (if take 6 src == "static" then text "static" else empty) - <+> pp_hdr - <+> (if isFun then empty else text "value") - <+> (pprWithSourceText st empty) - pprCEntity (CFunction DynamicTarget) _ = - doubleQuotes $ text "dynamic" - pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" - -instance Outputable ForeignExport where - ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = - ppr cconv <+> char '"' <> ppr lbl <> char '"' - -{- -************************************************************************ -* * -\subsection{Transformation rules} -* * -************************************************************************ --} - --- | Located Rule Declarations -type LRuleDecls pass = Located (RuleDecls pass) - - -- Note [Pragma source text] in BasicTypes --- | Rule Declarations -data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass - , rds_src :: SourceText - , rds_rules :: [LRuleDecl pass] } - | XRuleDecls (XXRuleDecls pass) - -type instance XCRuleDecls (GhcPass _) = NoExtField -type instance XXRuleDecls (GhcPass _) = NoExtCon - --- | Located Rule Declaration -type LRuleDecl pass = Located (RuleDecl pass) - --- | Rule Declaration -data RuleDecl pass - = HsRule -- Source rule - { rd_ext :: XHsRule pass - -- ^ After renamer, free-vars from the LHS and RHS - , rd_name :: Located (SourceText,RuleName) - -- ^ Note [Pragma source text] in BasicTypes - , rd_act :: Activation - , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] - -- ^ Forall'd type vars - , rd_tmvs :: [LRuleBndr pass] - -- ^ Forall'd term vars, before typechecking; after typechecking - -- this includes all forall'd vars - , rd_lhs :: Located (HsExpr pass) - , rd_rhs :: Located (HsExpr pass) - } - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', - -- 'ApiAnnotation.AnnEqual', - | XRuleDecl (XXRuleDecl pass) - -data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS - deriving Data - -type instance XHsRule GhcPs = NoExtField -type instance XHsRule GhcRn = HsRuleRn -type instance XHsRule GhcTc = HsRuleRn - -type instance XXRuleDecl (GhcPass _) = NoExtCon - -flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] -flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls - --- | Located Rule Binder -type LRuleBndr pass = Located (RuleBndr pass) - --- | Rule Binder -data RuleBndr pass - = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) - | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass) - | XRuleBndr (XXRuleBndr pass) - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - -type instance XCRuleBndr (GhcPass _) = NoExtField -type instance XRuleBndrSig (GhcPass _) = NoExtField -type instance XXRuleBndr (GhcPass _) = NoExtCon - -collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] -collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] - -pprFullRuleName :: Located (SourceText, RuleName) -> SDoc -pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecls p) where - ppr (HsRules { rds_src = st - , rds_rules = rules }) - = pprWithSourceText st (text "{-# RULES") - <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" - ppr (XRuleDecls x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where - ppr (HsRule { rd_name = name - , rd_act = act - , rd_tyvs = tys - , rd_tmvs = tms - , rd_lhs = lhs - , rd_rhs = rhs }) - = sep [pprFullRuleName name <+> ppr act, - nest 4 (pp_forall_ty tys <+> pp_forall_tm tys - <+> pprExpr (unLoc lhs)), - nest 6 (equals <+> pprExpr (unLoc rhs)) ] - where - pp_forall_ty Nothing = empty - pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot - pp_forall_tm Nothing | null tms = empty - pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot - ppr (XRuleDecl x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where - ppr (RuleBndr _ name) = ppr name - ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) - ppr (XRuleBndr x) = ppr x - -{- -************************************************************************ -* * -\subsection[DocDecl]{Document comments} -* * -************************************************************************ --} - --- | Located Documentation comment Declaration -type LDocDecl = Located (DocDecl) - --- | Documentation comment Declaration -data DocDecl - = DocCommentNext HsDocString - | DocCommentPrev HsDocString - | DocCommentNamed String HsDocString - | DocGroup Int HsDocString - deriving Data - --- Okay, I need to reconstruct the document comments, but for now: -instance Outputable DocDecl where - ppr _ = text "" - -docDeclDoc :: DocDecl -> HsDocString -docDeclDoc (DocCommentNext d) = d -docDeclDoc (DocCommentPrev d) = d -docDeclDoc (DocCommentNamed _ d) = d -docDeclDoc (DocGroup _ d) = d - -{- -************************************************************************ -* * -\subsection[DeprecDecl]{Deprecations} -* * -************************************************************************ - -We use exported entities for things to deprecate. --} - --- | Located Warning Declarations -type LWarnDecls pass = Located (WarnDecls pass) - - -- Note [Pragma source text] in BasicTypes --- | Warning pragma Declarations -data WarnDecls pass = Warnings { wd_ext :: XWarnings pass - , wd_src :: SourceText - , wd_warnings :: [LWarnDecl pass] - } - | XWarnDecls (XXWarnDecls pass) - -type instance XWarnings (GhcPass _) = NoExtField -type instance XXWarnDecls (GhcPass _) = NoExtCon - --- | Located Warning pragma Declaration -type LWarnDecl pass = Located (WarnDecl pass) - --- | Warning pragma Declaration -data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt - | XWarnDecl (XXWarnDecl pass) - -type instance XWarning (GhcPass _) = NoExtField -type instance XXWarnDecl (GhcPass _) = NoExtCon - - -instance (p ~ GhcPass pass,OutputableBndr (IdP p)) - => Outputable (WarnDecls p) where - ppr (Warnings _ (SourceText src) decls) - = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" - ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" - ppr (XWarnDecls x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndr (IdP p)) - => Outputable (WarnDecl p) where - ppr (Warning _ thing txt) - = hsep ( punctuate comma (map ppr thing)) - <+> ppr txt - ppr (XWarnDecl x) = ppr x - -{- -************************************************************************ -* * -\subsection[AnnDecl]{Annotations} -* * -************************************************************************ --} - --- | Located Annotation Declaration -type LAnnDecl pass = Located (AnnDecl pass) - --- | Annotation Declaration -data AnnDecl pass = HsAnnotation - (XHsAnnotation pass) - SourceText -- Note [Pragma source text] in BasicTypes - (AnnProvenance (IdP pass)) (Located (HsExpr pass)) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnType' - -- 'ApiAnnotation.AnnModule' - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | XAnnDecl (XXAnnDecl pass) - -type instance XHsAnnotation (GhcPass _) = NoExtField -type instance XXAnnDecl (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where - ppr (HsAnnotation _ _ provenance expr) - = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] - ppr (XAnnDecl x) = ppr x - --- | Annotation Provenance -data AnnProvenance name = ValueAnnProvenance (Located name) - | TypeAnnProvenance (Located name) - | ModuleAnnProvenance -deriving instance Functor AnnProvenance -deriving instance Foldable AnnProvenance -deriving instance Traversable AnnProvenance -deriving instance (Data pass) => Data (AnnProvenance pass) - -annProvenanceName_maybe :: AnnProvenance name -> Maybe name -annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name -annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name -annProvenanceName_maybe ModuleAnnProvenance = Nothing - -pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc -pprAnnProvenance ModuleAnnProvenance = text "ANN module" -pprAnnProvenance (ValueAnnProvenance (L _ name)) - = text "ANN" <+> ppr name -pprAnnProvenance (TypeAnnProvenance (L _ name)) - = text "ANN type" <+> ppr name - -{- -************************************************************************ -* * -\subsection[RoleAnnot]{Role annotations} -* * -************************************************************************ --} - --- | Located Role Annotation Declaration -type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass) - --- See #8185 for more info about why role annotations are --- top-level declarations --- | Role Annotation Declaration -data RoleAnnotDecl pass - = RoleAnnotDecl (XCRoleAnnotDecl pass) - (Located (IdP pass)) -- type constructor - [Located (Maybe Role)] -- optional annotations - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', - -- 'ApiAnnotation.AnnRole' - - -- For details on above see note [Api annotations] in ApiAnnotation - | XRoleAnnotDecl (XXRoleAnnotDecl pass) - -type instance XCRoleAnnotDecl (GhcPass _) = NoExtField -type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndr (IdP p)) - => Outputable (RoleAnnotDecl p) where - ppr (RoleAnnotDecl _ ltycon roles) - = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+> - hsep (map (pp_role . unLoc) roles) - where - pp_role Nothing = underscore - pp_role (Just r) = ppr r - ppr (XRoleAnnotDecl x) = ppr x - -roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p) -roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name -roleAnnotDeclName (XRoleAnnotDecl nec) = noExtCon nec diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs deleted file mode 100644 index affbf1bac0..0000000000 --- a/compiler/hsSyn/HsDoc.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module HsDoc - ( HsDocString - , LHsDocString - , mkHsDocString - , mkHsDocStringUtf8ByteString - , unpackHDS - , hsDocStringToByteString - , ppr_mbDoc - - , appendDocs - , concatDocs - - , DeclDocMap(..) - , emptyDeclDocMap - - , ArgDocMap(..) - , emptyArgDocMap - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import Binary -import Encoding -import FastFunctions -import Name -import Outputable -import SrcLoc - -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Internal as BS -import Data.Data -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Foreign - --- | Haskell Documentation String --- --- Internally this is a UTF8-Encoded 'ByteString'. -newtype HsDocString = HsDocString ByteString - -- There are at least two plausible Semigroup instances for this type: - -- - -- 1. Simple string concatenation. - -- 2. Concatenation as documentation paragraphs with newlines in between. - -- - -- To avoid confusion, we pass on defining an instance at all. - deriving (Eq, Show, Data) - --- | Located Haskell Documentation String -type LHsDocString = Located HsDocString - -instance Binary HsDocString where - put_ bh (HsDocString bs) = put_ bh bs - get bh = HsDocString <$> get bh - -instance Outputable HsDocString where - ppr = doubleQuotes . text . unpackHDS - -mkHsDocString :: String -> HsDocString -mkHsDocString s = - inlinePerformIO $ do - let len = utf8EncodedLength s - buf <- mallocForeignPtrBytes len - withForeignPtr buf $ \ptr -> do - utf8EncodeString ptr s - pure (HsDocString (BS.fromForeignPtr buf 0 len)) - --- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. -mkHsDocStringUtf8ByteString :: ByteString -> HsDocString -mkHsDocStringUtf8ByteString = HsDocString - -unpackHDS :: HsDocString -> String -unpackHDS = utf8DecodeByteString . hsDocStringToByteString - --- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'. -hsDocStringToByteString :: HsDocString -> ByteString -hsDocStringToByteString (HsDocString bs) = bs - -ppr_mbDoc :: Maybe LHsDocString -> SDoc -ppr_mbDoc (Just doc) = ppr doc -ppr_mbDoc Nothing = empty - --- | Join two docstrings. --- --- Non-empty docstrings are joined with two newlines in between, --- resulting in separate paragraphs. -appendDocs :: HsDocString -> HsDocString -> HsDocString -appendDocs x y = - fromMaybe - (HsDocString BS.empty) - (concatDocs [x, y]) - --- | Concat docstrings with two newlines in between. --- --- Empty docstrings are skipped. --- --- If all inputs are empty, 'Nothing' is returned. -concatDocs :: [HsDocString] -> Maybe HsDocString -concatDocs xs = - if BS.null b - then Nothing - else Just (HsDocString b) - where - b = BS.intercalate (C8.pack "\n\n") - . filter (not . BS.null) - . map hsDocStringToByteString - $ xs - --- | Docs for declarations: functions, data types, instances, methods etc. -newtype DeclDocMap = DeclDocMap (Map Name HsDocString) - -instance Binary DeclDocMap where - put_ bh (DeclDocMap m) = put_ bh (Map.toList m) - -- We can't rely on a deterministic ordering of the `Name`s here. - -- See the comments on `Name`'s `Ord` instance for context. - get bh = DeclDocMap . Map.fromList <$> get bh - -instance Outputable DeclDocMap where - ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m)) - where - pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc) - -emptyDeclDocMap :: DeclDocMap -emptyDeclDocMap = DeclDocMap Map.empty - --- | Docs for arguments. E.g. function arguments, method arguments. -newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString)) - -instance Binary ArgDocMap where - put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m)) - -- We can't rely on a deterministic ordering of the `Name`s here. - -- See the comments on `Name`'s `Ord` instance for context. - get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh - -instance Outputable ArgDocMap where - ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) - where - pprPair (name, int_map) = - ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map) - pprIntMap im = vcat (map pprIPair (Map.toAscList im)) - pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) - -emptyArgDocMap :: ArgDocMap -emptyArgDocMap = ArgDocMap Map.empty diff --git a/compiler/hsSyn/HsDumpAst.hs b/compiler/hsSyn/HsDumpAst.hs deleted file mode 100644 index 1a1c259c01..0000000000 --- a/compiler/hsSyn/HsDumpAst.hs +++ /dev/null @@ -1,220 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Contains a debug function to dump parts of the hsSyn AST. It uses a syb --- traversal which falls back to displaying based on the constructor name, so --- can be used to dump anything having a @Data.Data@ instance. - -module HsDumpAst ( - -- * Dumping ASTs - showAstData, - BlankSrcSpan(..), - ) where - -import GhcPrelude - -import Data.Data hiding (Fixity) -import Bag -import BasicTypes -import FastString -import NameSet -import Name -import DataCon -import SrcLoc -import HsSyn -import OccName hiding (occName) -import Var -import Module -import Outputable - -import qualified Data.ByteString as B - -data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan - deriving (Eq,Show) - --- | Show a GHC syntax tree. This parameterised because it is also used for --- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked --- out, to avoid comparing locations, only structure -showAstData :: Data a => BlankSrcSpan -> a -> SDoc -showAstData b a0 = blankLine $$ showAstData' a0 - where - showAstData' :: Data a => a -> SDoc - showAstData' = - generic - `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan - `extQ` lit `extQ` litr `extQ` litt - `extQ` bytestring - `extQ` name `extQ` occName `extQ` moduleName `extQ` var - `extQ` dataCon - `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet - `extQ` fixity - `ext2Q` located - - where generic :: Data a => a -> SDoc - generic t = parens $ text (showConstr (toConstr t)) - $$ vcat (gmapQ showAstData' t) - - string :: String -> SDoc - string = text . normalize_newlines . show - - fastString :: FastString -> SDoc - fastString s = braces $ - text "FastString: " - <> text (normalize_newlines . show $ s) - - bytestring :: B.ByteString -> SDoc - bytestring = text . normalize_newlines . show - - list [] = brackets empty - list [x] = brackets (showAstData' x) - list (x1 : x2 : xs) = (text "[" <> showAstData' x1) - $$ go x2 xs - where - go y [] = text "," <> showAstData' y <> text "]" - go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys - - -- Eliminate word-size dependence - lit :: HsLit GhcPs -> SDoc - lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - lit l = generic l - - litr :: HsLit GhcRn -> SDoc - litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - litr l = generic l - - litt :: HsLit GhcTc -> SDoc - litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - litt l = generic l - - numericLit :: String -> Integer -> SourceText -> SDoc - numericLit tag x s = braces $ hsep [ text tag - , generic x - , generic s ] - - name :: Name -> SDoc - name nm = braces $ text "Name: " <> ppr nm - - occName n = braces $ - text "OccName: " - <> text (OccName.occNameString n) - - moduleName :: ModuleName -> SDoc - moduleName m = braces $ text "ModuleName: " <> ppr m - - srcSpan :: SrcSpan -> SDoc - srcSpan ss = case b of - BlankSrcSpan -> text "{ ss }" - NoBlankSrcSpan -> braces $ char ' ' <> - (hang (ppr ss) 1 - -- TODO: show annotations here - (text "")) - - var :: Var -> SDoc - var v = braces $ text "Var: " <> ppr v - - dataCon :: DataCon -> SDoc - dataCon c = braces $ text "DataCon: " <> ppr c - - bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc - bagRdrName bg = braces $ - text "Bag(Located (HsBind GhcPs)):" - $$ (list . bagToList $ bg) - - bagName :: Bag (Located (HsBind GhcRn)) -> SDoc - bagName bg = braces $ - text "Bag(Located (HsBind Name)):" - $$ (list . bagToList $ bg) - - bagVar :: Bag (Located (HsBind GhcTc)) -> SDoc - bagVar bg = braces $ - text "Bag(Located (HsBind Var)):" - $$ (list . bagToList $ bg) - - nameSet ns = braces $ - text "NameSet:" - $$ (list . nameSetElemsStable $ ns) - - fixity :: Fixity -> SDoc - fixity fx = braces $ - text "Fixity: " - <> ppr fx - - located :: (Data b,Data loc) => GenLocated loc b -> SDoc - located (L ss a) = parens $ - case cast ss of - Just (s :: SrcSpan) -> - srcSpan s - Nothing -> text "nnnnnnnn" - $$ showAstData' a - -normalize_newlines :: String -> String -normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs -normalize_newlines (x:xs) = x:normalize_newlines xs -normalize_newlines [] = [] - -{- -************************************************************************ -* * -* Copied from syb -* * -************************************************************************ --} - - --- | The type constructor for queries -newtype Q q x = Q { unQ :: x -> q } - --- | Extend a generic query by a type-specific case -extQ :: ( Typeable a - , Typeable b - ) - => (a -> q) - -> (b -> q) - -> a - -> q -extQ f g a = maybe (f a) g (cast a) - --- | Type extension of queries for type constructors -ext1Q :: (Data d, Typeable t) - => (d -> q) - -> (forall e. Data e => t e -> q) - -> d -> q -ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) - - --- | Type extension of queries for type constructors -ext2Q :: (Data d, Typeable t) - => (d -> q) - -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) - -> d -> q -ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) - --- | Flexible type extension -ext1 :: (Data a, Typeable t) - => c a - -> (forall d. Data d => c (t d)) - -> c a -ext1 def ext = maybe def id (dataCast1 ext) - - - --- | Flexible type extension -ext2 :: (Data a, Typeable t) - => c a - -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) - -> c a -ext2 def ext = maybe def id (dataCast2 ext) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs deleted file mode 100644 index 69379bc1ad..0000000000 --- a/compiler/hsSyn/HsExpr.hs +++ /dev/null @@ -1,2828 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TypeFamilies #-} - --- | Abstract Haskell syntax for expressions. -module HsExpr where - -#include "HsVersions.h" - --- friends: -import GhcPrelude - -import HsDecls -import HsPat -import HsLit -import PlaceHolder ( NameOrRdrName ) -import HsExtension -import HsTypes -import HsBinds - --- others: -import TcEvidence -import CoreSyn -import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) -import Name -import NameSet -import RdrName ( GlobalRdrEnv ) -import BasicTypes -import ConLike -import SrcLoc -import Util -import Outputable -import FastString -import Type -import TcType (TcType) -import {-# SOURCE #-} TcRnTypes (TcLclEnv) - --- libraries: -import Data.Data hiding (Fixity(..)) -import qualified Data.Data as Data (Fixity(..)) -import Data.Maybe (isNothing) - -import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) - -{- -************************************************************************ -* * -\subsection{Expressions proper} -* * -************************************************************************ --} - --- * Expressions proper - --- | Located Haskell Expression -type LHsExpr p = Located (HsExpr p) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - -------------------------- --- | Post-Type checking Expression --- --- PostTcExpr is an evidence expression attached to the syntax tree by the --- type checker (c.f. postTcType). -type PostTcExpr = HsExpr GhcTc - --- | Post-Type checking Table --- --- We use a PostTcTable where there are a bunch of pieces of evidence, more --- than is convenient to keep individually. -type PostTcTable = [(Name, PostTcExpr)] - -------------------------- --- | Syntax Expression --- --- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, --- by the renamer. It's used for rebindable syntax. --- --- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for --- @(>>=)@, and then instantiated by the type checker with its type args --- etc --- --- This should desugar to --- --- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) --- > (syn_arg_wraps[1] arg1) ... --- --- where the actual arguments come from elsewhere in the AST. --- This could be defined using @GhcPass p@ and such, but it's --- harder to get it all to work out that way. ('noSyntaxExpr' is hard to --- write, for example.) -data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p - , syn_arg_wraps :: [HsWrapper] - , syn_res_wrap :: HsWrapper } - --- | This is used for rebindable-syntax pieces that are too polymorphic --- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) -noExpr :: HsExpr (GhcPass p) -noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) - -noSyntaxExpr :: SyntaxExpr (GhcPass p) - -- Before renaming, and sometimes after, - -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExtField - (HsString NoSourceText - (fsLit "noSyntaxExpr")) - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers. -mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p) -mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr - , syn_arg_wraps = [] - , syn_res_wrap = WpHole } - --- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the --- renamer), missing its HsWrappers. -mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn -mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name - -- don't care about filling in syn_arg_wraps because we're clearly - -- not past the typechecker - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (SyntaxExpr p) where - ppr (SyntaxExpr { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = sdocWithDynFlags $ \ dflags -> - getPprStyle $ \s -> - if debugStyle s || gopt Opt_PrintExplicitCoercions dflags - then ppr expr <> braces (pprWithCommas ppr arg_wraps) - <> braces (ppr res_wrap) - else ppr expr - --- | Command Syntax Table (for Arrow syntax) -type CmdSyntaxTable p = [(Name, HsExpr p)] --- See Note [CmdSyntaxTable] - -{- -Note [CmdSyntaxtable] -~~~~~~~~~~~~~~~~~~~~~ -Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps -track of the methods needed for a Cmd. - -* Before the renamer, this list is an empty list - -* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ - For example, for the 'arr' method - * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) - * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) - where @arr_22@ is whatever 'arr' is in scope - -* After the type checker, it takes the form [(std_name, )] - where is the evidence for the method. This evidence is - instantiated with the class, but is still polymorphic in everything - else. For example, in the case of 'arr', the evidence has type - forall b c. (b->c) -> a b c - where 'a' is the ambient type of the arrow. This polymorphism is - important because the desugarer uses the same evidence at multiple - different types. - -This is Less Cool than what we normally do for rebindable syntax, which is to -make fully-instantiated piece of evidence at every use site. The Cmd way -is Less Cool because - * The renamer has to predict which methods are needed. - See the tedious RnExpr.methodNamesCmd. - - * The desugarer has to know the polymorphic type of the instantiated - method. This is checked by Inst.tcSyntaxName, but is less flexible - than the rest of rebindable syntax, where the type is less - pre-ordained. (And this flexibility is useful; for example we can - typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) --} - --- | An unbound variable; used for treating --- out-of-scope variables as expression holes --- --- Either "x", "y" Plain OutOfScope --- or "_", "_x" A TrueExprHole --- --- Both forms indicate an out-of-scope variable, but the latter --- indicates that the user /expects/ it to be out of scope, and --- just wants GHC to report its type -data UnboundVar - = OutOfScope OccName GlobalRdrEnv -- ^ An (unqualified) out-of-scope - -- variable, together with the GlobalRdrEnv - -- with respect to which it is unbound - - -- See Note [OutOfScope and GlobalRdrEnv] - - | TrueExprHole OccName -- ^ A "true" expression hole (_ or _x) - - deriving Data - -instance Outputable UnboundVar where - ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ) - ppr (TrueExprHole occ) = text "ExprHole" <> parens (ppr occ) - -unboundVarOcc :: UnboundVar -> OccName -unboundVarOcc (OutOfScope occ _) = occ -unboundVarOcc (TrueExprHole occ) = occ - -{- -Note [OutOfScope and GlobalRdrEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To understand why we bundle a GlobalRdrEnv with an out-of-scope variable, -consider the following module: - - module A where - - foo :: () - foo = bar - - bat :: [Double] - bat = [1.2, 3.4] - - $(return []) - - bar = () - bad = False - -When A is compiled, the renamer determines that `bar` is not in scope in the -declaration of `foo` (since `bar` is declared in the following inter-splice -group). Once it has finished typechecking the entire module, the typechecker -then generates the associated error message, which specifies both the type of -`bar` and a list of possible in-scope alternatives: - - A.hs:6:7: error: - • Variable not in scope: bar :: () - • ‘bar’ (line 13) is not in scope before the splice on line 11 - Perhaps you meant ‘bat’ (line 9) - -When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the -typechecker must provide a GlobalRdrEnv. If it provided the current one, which -contains top-level declarations for the entire module, the error message would -incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives -for `bar` (see #11680). Instead, the typechecker must use the same -GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope. - -To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope -`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to -look it up in some global store? Unfortunately, no. The problem is that -location information is not always sufficient for this task. This is most -apparent when dealing with the TH function addTopDecls, which adds its -declarations to the FOLLOWING inter-splice group. Consider these declarations: - - ex9 = cat -- cat is NOT in scope here - - $(do ------------------------------------------------------------- - ds <- [d| f = cab -- cat and cap are both in scope here - cat = () - |] - addTopDecls ds - [d| g = cab -- only cap is in scope here - cap = True - |]) - - ex10 = cat -- cat is NOT in scope here - - $(return []) ----------------------------------------------------- - - ex11 = cat -- cat is in scope - -Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs -the GlobalRdrEnvs which were used when they were renamed. These GlobalRdrEnvs -are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the -locations of the two `cab`s are the same (they are both created in the same -splice). Thus, we must include some additional information with each `cab` to -allow the typechecker to obtain the correct GlobalRdrEnv. Clearly, the simplest -information to use is the GlobalRdrEnv itself. --} - --- | A Haskell expression. -data HsExpr p - = HsVar (XVar p) - (Located (IdP p)) -- ^ Variable - - -- See Note [Located RdrNames] - - | HsUnboundVar (XUnboundVar p) - UnboundVar -- ^ Unbound variable; also used for "holes" - -- (_ or _x). - -- Turned from HsVar to HsUnboundVar by the - -- renamer, when it finds an out-of-scope - -- variable or hole. - -- Turned into HsVar by type checker, to support - -- deferred type errors. - - | HsConLikeOut (XConLikeOut p) - ConLike -- ^ After typechecker only; must be different - -- HsVar for pretty printing - - | HsRecFld (XRecFld p) - (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector - -- Not in use after typechecking - - | HsOverLabel (XOverLabel p) - (Maybe (IdP p)) FastString - -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) - -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the - -- in-scope 'fromLabel'. - -- NB: Not in use after typechecking - - | HsIPVar (XIPVar p) - HsIPName -- ^ Implicit parameter (not in use after typechecking) - | HsOverLit (XOverLitE p) - (HsOverLit p) -- ^ Overloaded literals - - | HsLit (XLitE p) - (HsLit p) -- ^ Simple (non-overloaded) literals - - | HsLam (XLam p) - (MatchGroup p (LHsExpr p)) - -- ^ Lambda abstraction. Currently always a single match - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application - - | HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application - -- - -- Explicit type argument; e.g f @Int x y - -- NB: Has wildcards, but no implicit quantification - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', - - -- | Operator applications: - -- NB Bracketed ops such as (+) come out as Vars. - - -- NB We need an expr for the operator in an OpApp/Section since - -- the typechecker may need to apply the operator to a few types. - - | OpApp (XOpApp p) - (LHsExpr p) -- left operand - (LHsExpr p) -- operator - (LHsExpr p) -- right operand - - -- | Negation operator. Contains the negated expression and the name - -- of 'negate' - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' - - -- For details on above see note [Api annotations] in ApiAnnotation - | NegApp (XNegApp p) - (LHsExpr p) - (SyntaxExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsPar (XPar p) - (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] - - | SectionL (XSectionL p) - (LHsExpr p) -- operand; see Note [Sections in HsSyn] - (LHsExpr p) -- operator - | SectionR (XSectionR p) - (LHsExpr p) -- operator; see Note [Sections in HsSyn] - (LHsExpr p) -- operand - - -- | Used for explicit tuples and sections thereof - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ExplicitTuple - (XExplicitTuple p) - [LHsTupArg p] - Boxity - - -- | Used for unboxed sum types - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@, - -- - -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before - -- the expression, (arity - alternative) after it - | ExplicitSum - (XExplicitSum p) - ConTag -- Alternative (one-based) - Arity -- Sum arity - (LHsExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', - -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCase (XCase p) - (LHsExpr p) - (MatchGroup p (LHsExpr p)) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', - -- 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnElse', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsIf (XIf p) - (Maybe (SyntaxExpr p)) -- cond function - -- Nothing => use the built-in 'if' - -- See Note [Rebindable if] - (LHsExpr p) -- predicate - (LHsExpr p) -- then part - (LHsExpr p) -- else part - - -- | Multi-way if - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf' - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] - - -- | let(rec) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', - -- 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsLet (XLet p) - (LHsLocalBinds p) - (LHsExpr p) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', - -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsDo (XDo p) -- Type of the whole expression - (HsStmtContext Name) -- The parameterisation is unimportant - -- because in this context we never use - -- the PatGuard or ParStmt variant - (Located [ExprLStmt p]) -- "do":one or more stmts - - -- | Syntactic list: [a,b,c,...] - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | ExplicitList - (XExplicitList p) -- Gives type of components of list - (Maybe (SyntaxExpr p)) - -- For OverloadedLists, the fromListN witness - [LHsExpr p] - - -- | Record construction - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecordCon - { rcon_ext :: XRecordCon p - , rcon_con_name :: Located (IdP p) -- The constructor name; - -- not used after type checking - , rcon_flds :: HsRecordBinds p } -- The fields - - -- | Record update - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecordUpd - { rupd_ext :: XRecordUpd p - , rupd_expr :: LHsExpr p - , rupd_flds :: [LHsRecUpdField p] - } - -- For a type family, the arg types are of the *instance* tycon, - -- not the family tycon - - -- | Expression with an explicit type signature. @e :: type@ - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ExprWithTySig - (XExprWithTySig p) - - (LHsExpr p) - (LHsSigWcType (NoGhcTc p)) - - -- | Arithmetic sequence - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | ArithSeq - (XArithSeq p) - (Maybe (SyntaxExpr p)) - -- For OverloadedLists, the fromList witness - (ArithSeqInfo p) - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsSCC (XSCC p) - SourceText -- Note [Pragma source text] in BasicTypes - StringLiteral -- "set cost centre" SCC pragma - (LHsExpr p) -- expr whose cost is to be measured - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, - -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCoreAnn (XCoreAnn p) - SourceText -- Note [Pragma source text] in BasicTypes - StringLiteral -- hdaume: core annotation - (LHsExpr p) - - ----------------------------------------------------------- - -- MetaHaskell Extensions - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ', - -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsBracket (XBracket p) (HsBracket p) - - -- See Note [Pending Splices] - | HsRnBracketOut - (XRnBracketOut p) - (HsBracket GhcRn) -- Output of the renamer is the *original* renamed - -- expression, plus - [PendingRnSplice] -- _renamed_ splices to be type checked - - | HsTcBracketOut - (XTcBracketOut p) - (HsBracket GhcRn) -- Output of the type checker is the *original* - -- renamed expression, plus - [PendingTcSplice] -- _typechecked_ splices to be - -- pasted back in by the desugarer - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsSpliceE (XSpliceE p) (HsSplice p) - - ----------------------------------------------------------- - -- Arrow notation extension - - -- | @proc@ notation for Arrows - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc', - -- 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsProc (XProc p) - (LPat p) -- arrow abstraction, proc - (LHsCmdTop p) -- body of the abstraction - -- always has an empty stack - - --------------------------------------- - -- static pointers extension - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsStatic (XStatic p) -- Free variables of the body - (LHsExpr p) -- Body - - --------------------------------------- - -- Haskell program coverage (Hpc) Support - - | HsTick - (XTick p) - (Tickish (IdP p)) - (LHsExpr p) -- sub-expression - - | HsBinTick - (XBinTick p) - Int -- module-local tick number for True - Int -- module-local tick number for False - (LHsExpr p) -- sub-expression - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnMinus', - -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose' @'\#-}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsTickPragma -- A pragma introduced tick - (XTickPragma p) - SourceText -- Note [Pragma source text] in BasicTypes - (StringLiteral,(Int,Int),(Int,Int)) - -- external span for this tick - ((SourceText,SourceText),(SourceText,SourceText)) - -- Source text for the four integers used in the span. - -- See note [Pragma source text] in BasicTypes - (LHsExpr p) - - --------------------------------------- - -- Finally, HsWrap appears only in typechecker output - -- The contained Expr is *NOT* itself an HsWrap. - -- See Note [Detecting forced eta expansion] in DsExpr. This invariant - -- is maintained by HsUtils.mkHsWrap. - - | HsWrap (XWrap p) - HsWrapper -- TRANSLATION - (HsExpr p) - - | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor - - --- | Extra data fields for a 'RecordCon', added by the type checker -data RecordConTc = RecordConTc - { rcon_con_like :: ConLike -- The data constructor or pattern synonym - , rcon_con_expr :: PostTcExpr -- Instantiated constructor function - } - --- | Extra data fields for a 'RecordUpd', added by the type checker -data RecordUpdTc = RecordUpdTc - { rupd_cons :: [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: [Type] -- Argument types of *input* record type - , rupd_out_tys :: [Type] -- and *output* record type - -- The original type can be reconstructed - -- with conLikeResTy - , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] - } deriving Data - --- --------------------------------------------------------------------- - -type instance XVar (GhcPass _) = NoExtField -type instance XUnboundVar (GhcPass _) = NoExtField -type instance XConLikeOut (GhcPass _) = NoExtField -type instance XRecFld (GhcPass _) = NoExtField -type instance XOverLabel (GhcPass _) = NoExtField -type instance XIPVar (GhcPass _) = NoExtField -type instance XOverLitE (GhcPass _) = NoExtField -type instance XLitE (GhcPass _) = NoExtField -type instance XLam (GhcPass _) = NoExtField -type instance XLamCase (GhcPass _) = NoExtField -type instance XApp (GhcPass _) = NoExtField - -type instance XAppTypeE (GhcPass _) = NoExtField - -type instance XOpApp GhcPs = NoExtField -type instance XOpApp GhcRn = Fixity -type instance XOpApp GhcTc = Fixity - -type instance XNegApp (GhcPass _) = NoExtField -type instance XPar (GhcPass _) = NoExtField -type instance XSectionL (GhcPass _) = NoExtField -type instance XSectionR (GhcPass _) = NoExtField -type instance XExplicitTuple (GhcPass _) = NoExtField - -type instance XExplicitSum GhcPs = NoExtField -type instance XExplicitSum GhcRn = NoExtField -type instance XExplicitSum GhcTc = [Type] - -type instance XCase (GhcPass _) = NoExtField -type instance XIf (GhcPass _) = NoExtField - -type instance XMultiIf GhcPs = NoExtField -type instance XMultiIf GhcRn = NoExtField -type instance XMultiIf GhcTc = Type - -type instance XLet (GhcPass _) = NoExtField - -type instance XDo GhcPs = NoExtField -type instance XDo GhcRn = NoExtField -type instance XDo GhcTc = Type - -type instance XExplicitList GhcPs = NoExtField -type instance XExplicitList GhcRn = NoExtField -type instance XExplicitList GhcTc = Type - -type instance XRecordCon GhcPs = NoExtField -type instance XRecordCon GhcRn = NoExtField -type instance XRecordCon GhcTc = RecordConTc - -type instance XRecordUpd GhcPs = NoExtField -type instance XRecordUpd GhcRn = NoExtField -type instance XRecordUpd GhcTc = RecordUpdTc - -type instance XExprWithTySig (GhcPass _) = NoExtField - -type instance XArithSeq GhcPs = NoExtField -type instance XArithSeq GhcRn = NoExtField -type instance XArithSeq GhcTc = PostTcExpr - -type instance XSCC (GhcPass _) = NoExtField -type instance XCoreAnn (GhcPass _) = NoExtField -type instance XBracket (GhcPass _) = NoExtField - -type instance XRnBracketOut (GhcPass _) = NoExtField -type instance XTcBracketOut (GhcPass _) = NoExtField - -type instance XSpliceE (GhcPass _) = NoExtField -type instance XProc (GhcPass _) = NoExtField - -type instance XStatic GhcPs = NoExtField -type instance XStatic GhcRn = NameSet -type instance XStatic GhcTc = NameSet - -type instance XTick (GhcPass _) = NoExtField -type instance XBinTick (GhcPass _) = NoExtField -type instance XTickPragma (GhcPass _) = NoExtField -type instance XWrap (GhcPass _) = NoExtField -type instance XXExpr (GhcPass _) = NoExtCon - --- --------------------------------------------------------------------- - --- | Located Haskell Tuple Argument --- --- 'HsTupArg' is used for tuple sections --- @(,a,)@ is represented by --- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ --- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ -type LHsTupArg id = Located (HsTupArg id) --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' - --- For details on above see note [Api annotations] in ApiAnnotation - --- | Haskell Tuple Argument -data HsTupArg id - = Present (XPresent id) (LHsExpr id) -- ^ The argument - | Missing (XMissing id) -- ^ The argument is missing, but this is its type - | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point - -type instance XPresent (GhcPass _) = NoExtField - -type instance XMissing GhcPs = NoExtField -type instance XMissing GhcRn = NoExtField -type instance XMissing GhcTc = Type - -type instance XXTupArg (GhcPass _) = NoExtCon - -tupArgPresent :: LHsTupArg id -> Bool -tupArgPresent (L _ (Present {})) = True -tupArgPresent (L _ (Missing {})) = False -tupArgPresent (L _ (XTupArg {})) = False - -{- -Note [Parens in HsSyn] -~~~~~~~~~~~~~~~~~~~~~~ -HsPar (and ParPat in patterns, HsParTy in types) is used as follows - - * HsPar is required; the pretty printer does not add parens. - - * HsPars are respected when rearranging operator fixities. - So a * (b + c) means what it says (where the parens are an HsPar) - - * For ParPat and HsParTy the pretty printer does add parens but this should be - a no-op for ParsedSource, based on the pretty printer round trip feature - introduced in - https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c - - * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or - not they are strictly necessary. This should be addressed when #13238 is - completed, to be treated the same as HsPar. - - -Note [Sections in HsSyn] -~~~~~~~~~~~~~~~~~~~~~~~~ -Sections should always appear wrapped in an HsPar, thus - HsPar (SectionR ...) -The parser parses sections in a wider variety of situations -(See Note [Parsing sections]), but the renamer checks for those -parens. This invariant makes pretty-printing easier; we don't need -a special case for adding the parens round sections. - -Note [Rebindable if] -~~~~~~~~~~~~~~~~~~~~ -The rebindable syntax for 'if' is a bit special, because when -rebindable syntax is *off* we do not want to treat - (if c then t else e) -as if it was an application (ifThenElse c t e). Why not? -Because we allow an 'if' to return *unboxed* results, thus - if blah then 3# else 4# -whereas that would not be possible using a all to a polymorphic function -(because you can't call a polymorphic function at an unboxed type). - -So we use Nothing to mean "use the old built-in typing rule". - -Note [Record Update HsWrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a wrapper in RecordUpd which is used for the *required* -constraints for pattern synonyms. This wrapper is created in the -typechecking and is then directly used in the desugaring without -modification. - -For example, if we have the record pattern synonym P, - pattern P :: (Show a) => a -> Maybe a - pattern P{x} = Just x - - foo = (Just True) { x = False } -then `foo` desugars to something like - foo = case Just True of - P x -> P False -hence we need to provide the correct dictionaries to P's matcher on -the RHS so that we can build the expression. - -Note [Located RdrNames] -~~~~~~~~~~~~~~~~~~~~~~~ -A number of syntax elements have seemingly redundant locations attached to them. -This is deliberate, to allow transformations making use of the API Annotations -to easily correlate a Located Name in the RenamedSource with a Located RdrName -in the ParsedSource. - -There are unfortunately enough differences between the ParsedSource and the -RenamedSource that the API Annotations cannot be used directly with -RenamedSource, so this allows a simple mapping to be used based on the location. --} - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) where - ppr expr = pprExpr expr - ------------------------ --- pprExpr, pprLExpr, pprBinds call pprDeeper; --- the underscore versions do not -pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc -pprLExpr (L _ e) = pprExpr e - -pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc -pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e - | otherwise = pprDeeper (ppr_expr e) - -isQuietHsExpr :: HsExpr id -> Bool --- Parentheses do display something, but it gives little info and --- if we go deeper when we go inside them then we get ugly things --- like (...) -isQuietHsExpr (HsPar {}) = True --- applications don't display anything themselves -isQuietHsExpr (HsApp {}) = True -isQuietHsExpr (HsAppType {}) = True -isQuietHsExpr (OpApp {}) = True -isQuietHsExpr _ = False - -pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) - => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc -pprBinds b = pprDeeper (ppr b) - ------------------------ -ppr_lexpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc -ppr_lexpr e = ppr_expr (unLoc e) - -ppr_expr :: forall p. (OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) -> SDoc -ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v -ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv) -ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c -ppr_expr (HsIPVar _ v) = ppr v -ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l -ppr_expr (HsLit _ lit) = ppr lit -ppr_expr (HsOverLit _ lit) = ppr lit -ppr_expr (HsPar _ e) = parens (ppr_lexpr e) - -ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) - = vcat [pprWithSourceText stc (text "{-# CORE") - <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" - , ppr_lexpr e] - -ppr_expr e@(HsApp {}) = ppr_apps e [] -ppr_expr e@(HsAppType {}) = ppr_apps e [] - -ppr_expr (OpApp _ e1 op e2) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - - where - pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens - pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear - - pp_prefixly - = hang (ppr op) 2 (sep [pp_e1, pp_e2]) - - pp_infixly pp_op - = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) - -ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e - -ppr_expr (SectionL _ expr op) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - where - pp_expr = pprDebugParendExpr opPrec expr - - pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) - 4 (hsep [pp_expr, text "x_ )"]) - - pp_infixly v = (sep [pp_expr, v]) - -ppr_expr (SectionR _ op expr) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - where - pp_expr = pprDebugParendExpr opPrec expr - - pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) - 4 (pp_expr <> rparen) - - pp_infixly v = sep [v, pp_expr] - -ppr_expr (ExplicitTuple _ exprs boxity) - = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) - where - ppr_tup_args [] = [] - ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es - ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es - ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es - - punc (Present {} : _) = comma <> space - punc (Missing {} : _) = comma - punc (XTupArg {} : _) = comma <> space - punc [] = empty - -ppr_expr (ExplicitSum _ alt arity expr) - = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" - where - ppr_bars n = hsep (replicate n (char '|')) - -ppr_expr (HsLam _ matches) - = pprMatches matches - -ppr_expr (HsLamCase _ matches) - = sep [ sep [text "\\case"], - nest 2 (pprMatches matches) ] - -ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], - nest 2 (pprMatches matches) <+> char '}'] -ppr_expr (HsCase _ expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], - nest 2 (pprMatches matches) ] - -ppr_expr (HsIf _ _ e1 e2 e3) - = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], - nest 4 (ppr e2), - text "else", - nest 4 (ppr e3)] - -ppr_expr (HsMultiIf _ alts) - = hang (text "if") 3 (vcat (map ppr_alt alts)) - where ppr_alt (L _ (GRHS _ guards expr)) = - hang vbar 2 (ppr_one one_alt) - where - ppr_one [] = panic "ppr_exp HsMultiIf" - ppr_one (h:t) = hang h 2 (sep t) - one_alt = [ interpp'SP guards - , text "->" <+> pprDeeper (ppr expr) ] - ppr_alt (L _ (XGRHS x)) = ppr x - --- special case: let ... in let ... -ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), - ppr_lexpr expr] - -ppr_expr (HsLet _ (L _ binds) expr) - = sep [hang (text "let") 2 (pprBinds binds), - hang (text "in") 2 (ppr expr)] - -ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts - -ppr_expr (ExplicitList _ _ exprs) - = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) - -ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) - = hang (ppr con_id) 2 (ppr rbinds) - -ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) - = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) - -ppr_expr (ExprWithTySig _ expr sig) - = hang (nest 2 (ppr_lexpr expr) <+> dcolon) - 4 (ppr sig) - -ppr_expr (ArithSeq _ _ info) = brackets (ppr info) - -ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) - = sep [ pprWithSourceText st (text "{-# SCC") - -- no doublequotes if stl empty, for the case where the SCC was written - -- without quotes. - <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", - ppr expr ] - -ppr_expr (HsWrap _ co_fn e) - = pprHsWrapper co_fn (\parens -> if parens then pprExpr e - else pprExpr e) - -ppr_expr (HsSpliceE _ s) = pprSplice s -ppr_expr (HsBracket _ b) = pprHsBracket b -ppr_expr (HsRnBracketOut _ e []) = ppr e -ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps -ppr_expr (HsTcBracketOut _ e []) = ppr e -ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps - -ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) - = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] -ppr_expr (HsProc _ pat (L _ (XCmdTop x))) - = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x] - -ppr_expr (HsStatic _ e) - = hsep [text "static", ppr e] - -ppr_expr (HsTick _ tickish exp) - = pprTicks (ppr exp) $ - ppr tickish <+> ppr_lexpr exp -ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) - = pprTicks (ppr exp) $ - hcat [text "bintick<", - ppr tickIdTrue, - text ",", - ppr tickIdFalse, - text ">(", - ppr exp, text ")"] -ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) - = pprTicks (ppr exp) $ - hcat [text "tickpragma<", - pprExternalSrcLoc externalSrcLoc, - text ">(", - ppr exp, - text ")"] - -ppr_expr (HsRecFld _ f) = ppr f -ppr_expr (XExpr x) = ppr x - -ppr_infix_expr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> Maybe SDoc -ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) -ppr_infix_expr (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) -ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) -ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h)) -ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e -ppr_infix_expr _ = Nothing - -ppr_apps :: (OutputableBndrId (GhcPass p)) - => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] - -> SDoc -ppr_apps (HsApp _ (L _ fun) arg) args - = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType _ (L _ fun) arg) args - = ppr_apps fun (Right arg : args) -ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) - where - pp (Left arg) = ppr arg - -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) - -- = char '@' <> pprHsType arg - pp (Right arg) - = char '@' <> ppr arg - -pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc -pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) - = ppr (src,(n1,n2),(n3,n4)) - -{- -HsSyn records exactly where the user put parens, with HsPar. -So generally speaking we print without adding any parens. -However, some code is internally generated, and in some places -parens are absolutely required; so for these places we use -pprParendLExpr (but don't print double parens of course). - -For operator applications we don't add parens, because the operator -fixities should do the job, except in debug mode (-dppr-debug) so we -can see the structure of the parse tree. --} - -pprDebugParendExpr :: (OutputableBndrId (GhcPass p)) - => PprPrec -> LHsExpr (GhcPass p) -> SDoc -pprDebugParendExpr p expr - = getPprStyle (\sty -> - if debugStyle sty then pprParendLExpr p expr - else pprLExpr expr) - -pprParendLExpr :: (OutputableBndrId (GhcPass p)) - => PprPrec -> LHsExpr (GhcPass p) -> SDoc -pprParendLExpr p (L _ e) = pprParendExpr p e - -pprParendExpr :: (OutputableBndrId (GhcPass p)) - => PprPrec -> HsExpr (GhcPass p) -> SDoc -pprParendExpr p expr - | hsExprNeedsParens p expr = parens (pprExpr expr) - | otherwise = pprExpr expr - -- Using pprLExpr makes sure that we go 'deeper' - -- I think that is usually (always?) right - --- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs --- parentheses under precedence @p@. -hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool -hsExprNeedsParens p = go - where - go (HsVar{}) = False - go (HsUnboundVar{}) = False - go (HsConLikeOut{}) = False - go (HsIPVar{}) = False - go (HsOverLabel{}) = False - go (HsLit _ l) = hsLitNeedsParens p l - go (HsOverLit _ ol) = hsOverLitNeedsParens p ol - go (HsPar{}) = False - go (HsCoreAnn _ _ _ (L _ e)) = go e - go (HsApp{}) = p >= appPrec - go (HsAppType {}) = p >= appPrec - go (OpApp{}) = p >= opPrec - go (NegApp{}) = p > topPrec - go (SectionL{}) = True - go (SectionR{}) = True - go (ExplicitTuple{}) = False - go (ExplicitSum{}) = False - go (HsLam{}) = p > topPrec - go (HsLamCase{}) = p > topPrec - go (HsCase{}) = p > topPrec - go (HsIf{}) = p > topPrec - go (HsMultiIf{}) = p > topPrec - go (HsLet{}) = p > topPrec - go (HsDo _ sc _) - | isComprehensionContext sc = False - | otherwise = p > topPrec - go (ExplicitList{}) = False - go (RecordUpd{}) = False - go (ExprWithTySig{}) = p >= sigPrec - go (ArithSeq{}) = False - go (HsSCC{}) = p >= appPrec - go (HsWrap _ _ e) = go e - go (HsSpliceE{}) = False - go (HsBracket{}) = False - go (HsRnBracketOut{}) = False - go (HsTcBracketOut{}) = False - go (HsProc{}) = p > topPrec - go (HsStatic{}) = p >= appPrec - go (HsTick _ _ (L _ e)) = go e - go (HsBinTick _ _ _ (L _ e)) = go e - go (HsTickPragma _ _ _ _ (L _ e)) = go e - go (RecordCon{}) = False - go (HsRecFld{}) = False - go (XExpr{}) = True - --- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, --- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. -parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -parenthesizeHsExpr p le@(L loc e) - | hsExprNeedsParens p e = L loc (HsPar noExtField le) - | otherwise = le - -isAtomicHsExpr :: HsExpr id -> Bool --- True of a single token -isAtomicHsExpr (HsVar {}) = True -isAtomicHsExpr (HsConLikeOut {}) = True -isAtomicHsExpr (HsLit {}) = True -isAtomicHsExpr (HsOverLit {}) = True -isAtomicHsExpr (HsIPVar {}) = True -isAtomicHsExpr (HsOverLabel {}) = True -isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e -isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) -isAtomicHsExpr (HsRecFld{}) = True -isAtomicHsExpr _ = False - -{- -************************************************************************ -* * -\subsection{Commands (in arrow abstractions)} -* * -************************************************************************ - -We re-use HsExpr to represent these. --} - --- | Located Haskell Command (for arrow syntax) -type LHsCmd id = Located (HsCmd id) - --- | Haskell Command (e.g. a "statement" in an Arrow proc block) -data HsCmd id - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', - -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', - -- 'ApiAnnotation.AnnRarrowtail' - - -- For details on above see note [Api annotations] in ApiAnnotation - = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) - (XCmdArrApp id) -- type of the arrow expressions f, - -- of the form a t t', where arg :: t - (LHsExpr id) -- arrow expression, f - (LHsExpr id) -- input expression, arg - HsArrAppType -- higher-order (-<<) or first-order (-<) - Bool -- True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@, - -- 'ApiAnnotation.AnnCloseB' @'|)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) - (XCmdArrForm id) - (LHsExpr id) -- The operator. - -- After type-checking, a type abstraction to be - -- applied to the type of the local environment tuple - LexicalFixity -- Whether the operator appeared prefix or infix when - -- parsed. - (Maybe Fixity) -- fixity (filled in by the renamer), for forms that - -- were converted from OpApp's by the renamer - [LHsCmdTop id] -- argument commands - - | HsCmdApp (XCmdApp id) - (LHsCmd id) - (LHsExpr id) - - | HsCmdLam (XCmdLam id) - (MatchGroup id (LHsCmd id)) -- kappa - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', - -- 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdPar (XCmdPar id) - (LHsCmd id) -- parenthesised command - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdCase (XCmdCase id) - (LHsExpr id) - (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', - -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdIf (XCmdIf id) - (Maybe (SyntaxExpr id)) -- cond function - (LHsExpr id) -- predicate - (LHsCmd id) -- then part - (LHsCmd id) -- else part - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', - -- 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnElse', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdLet (XCmdLet id) - (LHsLocalBinds id) -- let(rec) - (LHsCmd id) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', - -- 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdDo (XCmdDo id) -- Type of the whole expression - (Located [CmdLStmt id]) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', - -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnVbar', - -- 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsCmdWrap (XCmdWrap id) - HsWrapper - (HsCmd id) -- If cmd :: arg1 --> res - -- wrap :: arg1 "->" arg2 - -- Then (HsCmdWrap wrap cmd) :: arg2 --> res - | XCmd (XXCmd id) -- Note [Trees that Grow] extension point - -type instance XCmdArrApp GhcPs = NoExtField -type instance XCmdArrApp GhcRn = NoExtField -type instance XCmdArrApp GhcTc = Type - -type instance XCmdArrForm (GhcPass _) = NoExtField -type instance XCmdApp (GhcPass _) = NoExtField -type instance XCmdLam (GhcPass _) = NoExtField -type instance XCmdPar (GhcPass _) = NoExtField -type instance XCmdCase (GhcPass _) = NoExtField -type instance XCmdIf (GhcPass _) = NoExtField -type instance XCmdLet (GhcPass _) = NoExtField - -type instance XCmdDo GhcPs = NoExtField -type instance XCmdDo GhcRn = NoExtField -type instance XCmdDo GhcTc = Type - -type instance XCmdWrap (GhcPass _) = NoExtField -type instance XXCmd (GhcPass _) = NoExtCon - --- | Haskell Array Application Type -data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp - deriving Data - - -{- | Top-level command, introducing a new arrow. -This may occur inside a proc (where the stack is empty) or as an -argument of a command-forming operator. --} - --- | Located Haskell Top-level Command -type LHsCmdTop p = Located (HsCmdTop p) - --- | Haskell Top-level Command -data HsCmdTop p - = HsCmdTop (XCmdTop p) - (LHsCmd p) - | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point - -data CmdTopTc - = CmdTopTc Type -- Nested tuple of inputs on the command's stack - Type -- return type of the command - (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] - -type instance XCmdTop GhcPs = NoExtField -type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] -type instance XCmdTop GhcTc = CmdTopTc - -type instance XXCmdTop (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where - ppr cmd = pprCmd cmd - ------------------------ --- pprCmd and pprLCmd call pprDeeper; --- the underscore versions do not -pprLCmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc -pprLCmd (L _ c) = pprCmd c - -pprCmd :: (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc -pprCmd c | isQuietHsCmd c = ppr_cmd c - | otherwise = pprDeeper (ppr_cmd c) - -isQuietHsCmd :: HsCmd id -> Bool --- Parentheses do display something, but it gives little info and --- if we go deeper when we go inside them then we get ugly things --- like (...) -isQuietHsCmd (HsCmdPar {}) = True --- applications don't display anything themselves -isQuietHsCmd (HsCmdApp {}) = True -isQuietHsCmd _ = False - ------------------------ -ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc -ppr_lcmd c = ppr_cmd (unLoc c) - -ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc -ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) - -ppr_cmd (HsCmdApp _ c e) - = let (fun, args) = collect_args c [e] in - hang (ppr_lcmd fun) 2 (sep (map ppr args)) - where - collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) - collect_args fun args = (fun, args) - -ppr_cmd (HsCmdLam _ matches) - = pprMatches matches - -ppr_cmd (HsCmdCase _ expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], - nest 2 (pprMatches matches) ] - -ppr_cmd (HsCmdIf _ _ e ct ce) - = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], - nest 4 (ppr ct), - text "else", - nest 4 (ppr ce)] - --- special case: let ... in let ... -ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), - ppr_lcmd cmd] - -ppr_cmd (HsCmdLet _ (L _ binds) cmd) - = sep [hang (text "let") 2 (pprBinds binds), - hang (text "in") 2 (ppr cmd)] - -ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts - -ppr_cmd (HsCmdWrap _ w cmd) - = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) -ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) - = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) - = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) - = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) - = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] - -ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) - = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) - , pprCmdArg (unLoc arg2)]) -ppr_cmd (HsCmdArrForm _ op _ _ args) - = hang (text "(|" <+> ppr_lexpr op) - 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") -ppr_cmd (XCmd x) = ppr x - -pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc -pprCmdArg (HsCmdTop _ cmd) - = ppr_lcmd cmd -pprCmdArg (XCmdTop x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where - ppr = pprCmdArg - -{- -************************************************************************ -* * -\subsection{Record binds} -* * -************************************************************************ --} - --- | Haskell Record Bindings -type HsRecordBinds p = HsRecFields p (LHsExpr p) - -{- -************************************************************************ -* * -\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} -* * -************************************************************************ - -@Match@es are sets of pattern bindings and right hand sides for -functions, patterns or case branches. For example, if a function @g@ -is defined as: -\begin{verbatim} -g (x,y) = y -g ((x:ys),y) = y+1, -\end{verbatim} -then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. - -It is always the case that each element of an @[Match]@ list has the -same number of @pats@s inside it. This corresponds to saying that -a function defined by pattern matching must have the same number of -patterns in each equation. --} - -data MatchGroup p body - = MG { mg_ext :: XMG p body -- Posr typechecker, types of args and result - , mg_alts :: Located [LMatch p body] -- The alternatives - , mg_origin :: Origin } - -- The type is the type of the entire group - -- t1 -> ... -> tn -> tr - -- where there are n patterns - | XMatchGroup (XXMatchGroup p body) - -data MatchGroupTc - = MatchGroupTc - { mg_arg_tys :: [Type] -- Types of the arguments, t1..tn - , mg_res_ty :: Type -- Type of the result, tr - } deriving Data - -type instance XMG GhcPs b = NoExtField -type instance XMG GhcRn b = NoExtField -type instance XMG GhcTc b = MatchGroupTc - -type instance XXMatchGroup (GhcPass _) b = NoExtCon - --- | Located Match -type LMatch id body = Located (Match id body) --- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a --- list - --- For details on above see note [Api annotations] in ApiAnnotation -data Match p body - = Match { - m_ext :: XCMatch p body, - m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), - -- See note [m_ctxt in Match] - m_pats :: [LPat p], -- The patterns - m_grhss :: (GRHSs p body) - } - | XMatch (XXMatch p body) - -type instance XCMatch (GhcPass _) b = NoExtField -type instance XXMatch (GhcPass _) b = NoExtCon - -instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body) - => Outputable (Match idR body) where - ppr = pprMatch - -{- -Note [m_ctxt in Match] -~~~~~~~~~~~~~~~~~~~~~~ - -A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and -so on. - -In order to simplify tooling processing and pretty print output, the provenance -is captured in an HsMatchContext. - -This is particularly important for the API Annotations for a multi-equation -FunBind. - -The parser initially creates a FunBind with a single Match in it for -every function definition it sees. - -These are then grouped together by getMonoBind into a single FunBind, -where all the Matches are combined. - -In the process, all the original FunBind fun_id's bar one are -discarded, including the locations. - -This causes a problem for source to source conversions via API -Annotations, so the original fun_ids and infix flags are preserved in -the Match, when it originates from a FunBind. - -Example infix function definition requiring individual API Annotations - - (&&& ) [] [] = [] - xs &&& [] = xs - ( &&& ) [] ys = ys - - - --} - - -isInfixMatch :: Match id body -> Bool -isInfixMatch match = case m_ctxt match of - FunRhs {mc_fixity = Infix} -> True - _ -> False - -isEmptyMatchGroup :: MatchGroup id body -> Bool -isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms -isEmptyMatchGroup (XMatchGroup {}) = False - --- | Is there only one RHS in this list of matches? -isSingletonMatchGroup :: [LMatch id body] -> Bool -isSingletonMatchGroup matches - | [L _ match] <- matches - , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match - = True - | otherwise - = False - -matchGroupArity :: MatchGroup (GhcPass id) body -> Arity --- Precondition: MatchGroup is non-empty --- This is called before type checking, when mg_arg_tys is not set -matchGroupArity (MG { mg_alts = alts }) - | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) - | otherwise = panic "matchGroupArity" -matchGroupArity (XMatchGroup nec) = noExtCon nec - -hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] -hsLMatchPats (L _ (Match { m_pats = pats })) = pats -hsLMatchPats (L _ (XMatch nec)) = noExtCon nec - --- | Guarded Right-Hand Sides --- --- GRHSs are used both for pattern bindings and for Matches --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', --- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' --- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' - --- For details on above see note [Api annotations] in ApiAnnotation -data GRHSs p body - = GRHSs { - grhssExt :: XCGRHSs p body, - grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs - grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause - } - | XGRHSs (XXGRHSs p body) - -type instance XCGRHSs (GhcPass _) b = NoExtField -type instance XXGRHSs (GhcPass _) b = NoExtCon - --- | Located Guarded Right-Hand Side -type LGRHS id body = Located (GRHS id body) - --- | Guarded Right Hand Side. -data GRHS p body = GRHS (XCGRHS p body) - [GuardLStmt p] -- Guards - body -- Right hand side - | XGRHS (XXGRHS p body) - -type instance XCGRHS (GhcPass _) b = NoExtField -type instance XXGRHS (GhcPass _) b = NoExtCon - --- We know the list must have at least one @Match@ in it. - -pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc -pprMatches MG { mg_alts = matches } - = vcat (map pprMatch (map unLoc (unLoc matches))) - -- Don't print the type; it's only a place-holder before typechecking -pprMatches (XMatchGroup x) = ppr x - --- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc -pprFunBind matches = pprMatches matches - --- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr), - OutputableBndrId (GhcPass p), - Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc -pprPatBind pat (grhss) - = sep [ppr pat, - nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] - -pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body) - => Match (GhcPass idR) body -> SDoc -pprMatch match - = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) - , nest 2 (pprGRHSs ctxt (m_grhss match)) ] - where - ctxt = m_ctxt match - (herald, other_pats) - = case ctxt of - FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} - | strictness == SrcStrict -> ASSERT(null $ m_pats match) - (char '!'<>pprPrefixOcc fun, m_pats match) - -- a strict variable binding - | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) - -- f x y z = e - -- Not pprBndr; the AbsBinds will - -- have printed the signature - - | null pats2 -> (pp_infix, []) - -- x &&& y = e - - | otherwise -> (parens pp_infix, pats2) - -- (x &&& y) z = e - where - pp_infix = pprParendLPat opPrec pat1 - <+> pprInfixOcc fun - <+> pprParendLPat opPrec pat2 - - LambdaExpr -> (char '\\', m_pats match) - - _ -> if null (m_pats match) - then (empty, []) - else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 ) - (ppr pat1, []) -- No parens around the single pat - - (pat1:pats1) = m_pats match - (pat2:pats2) = pats1 - -pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body) - => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc -pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) - = vcat (map (pprGRHS ctxt . unLoc) grhss) - -- Print the "where" even if the contents of the binds is empty. Only - -- EmptyLocalBinds means no "where" keyword - $$ ppUnless (eqEmptyLocalBinds binds) - (text "where" $$ nest 4 (pprBinds binds)) -pprGRHSs _ (XGRHSs x) = ppr x - -pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body) - => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc -pprGRHS ctxt (GRHS _ [] body) - = pp_rhs ctxt body - -pprGRHS ctxt (GRHS _ guards body) - = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] - -pprGRHS _ (XGRHS x) = ppr x - -pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc -pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) - -{- -************************************************************************ -* * -\subsection{Do stmts and list comprehensions} -* * -************************************************************************ --} - --- | Located @do@ block Statement -type LStmt id body = Located (StmtLR id id body) - --- | Located Statement with separate Left and Right id's -type LStmtLR idL idR body = Located (StmtLR idL idR body) - --- | @do@ block Statement -type Stmt id body = StmtLR id id body - --- | Command Located Statement -type CmdLStmt id = LStmt id (LHsCmd id) - --- | Command Statement -type CmdStmt id = Stmt id (LHsCmd id) - --- | Expression Located Statement -type ExprLStmt id = LStmt id (LHsExpr id) - --- | Expression Statement -type ExprStmt id = Stmt id (LHsExpr id) - --- | Guard Located Statement -type GuardLStmt id = LStmt id (LHsExpr id) - --- | Guard Statement -type GuardStmt id = Stmt id (LHsExpr id) - --- | Ghci Located Statement -type GhciLStmt id = LStmt id (LHsExpr id) - --- | Ghci Statement -type GhciStmt id = Stmt id (LHsExpr id) - --- The SyntaxExprs in here are used *only* for do-notation and monad --- comprehensions, which have rebindable syntax. Otherwise they are unused. --- | API Annotations when in qualifier lists or guards --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', --- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen', --- 'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy', --- 'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing' - --- For details on above see note [Api annotations] in ApiAnnotation -data StmtLR idL idR body -- body should always be (LHs**** idR) - = LastStmt -- Always the last Stmt in ListComp, MonadComp, - -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr - -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff - (XLastStmt idL idR body) - body - Bool -- True <=> return was stripped by ApplicativeDo - (SyntaxExpr idR) -- The return operator - -- The return operator is used only for MonadComp - -- For ListComp we use the baked-in 'return' - -- For DoExpr, MDoExpr, we don't apply a 'return' at all - -- See Note [Monad Comprehensions] - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | BindStmt (XBindStmt idL idR body) -- Post typechecking, - -- result type of the function passed to bind; - -- that is, S in (>>=) :: Q -> (R -> S) -> T - (LPat idL) - body - (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts] - (SyntaxExpr idR) -- The fail operator - -- The fail operator is noSyntaxExpr - -- if the pattern match can't fail - - -- | 'ApplicativeStmt' represents an applicative expression built with - -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the - -- appropriate applicative expression by the desugarer, but it is intended - -- to be invisible in error messages. - -- - -- For full details, see Note [ApplicativeDo] in RnExpr - -- - | ApplicativeStmt - (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body - [ ( SyntaxExpr idR - , ApplicativeArg idL) ] - -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] - (Maybe (SyntaxExpr idR)) -- 'join', if necessary - - | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type - -- of the RHS (used for arrows) - body -- See Note [BodyStmt] - (SyntaxExpr idR) -- The (>>) operator - (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp - -- See notes [Monad Comprehensions] - - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' - -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, - - -- For details on above see note [Api annotations] in ApiAnnotation - | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) - - -- ParStmts only occur in a list/monad comprehension - | ParStmt (XParStmt idL idR body) -- Post typecheck, - -- S in (>>=) :: Q -> (R -> S) -> T - [ParStmtBlock idL idR] - (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions - (SyntaxExpr idR) -- The `>>=` operator - -- See notes [Monad Comprehensions] - -- After renaming, the ids are the binders - -- bound by the stmts and used after themp - - | TransStmt { - trS_ext :: XTransStmt idL idR body, -- Post typecheck, - -- R in (>>=) :: Q -> (R -> S) -> T - trS_form :: TransForm, - trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' - -- which generates the tuples to be grouped - - trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] - - trS_using :: LHsExpr idR, - trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) - -- Invariant: if trS_form = GroupBy, then grp_by = Just e - - trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for - -- the inner monad comprehensions - trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator - trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring - -- Only for 'group' forms - -- Just a simple HsExpr, because it's - -- too polymorphic for tcSyntaxOp - } -- See Note [Monad Comprehensions] - - -- Recursive statement (see Note [How RecStmt works] below) - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec' - - -- For details on above see note [Api annotations] in ApiAnnotation - | RecStmt - { recS_ext :: XRecStmt idL idR body - , recS_stmts :: [LStmtLR idL idR body] - - -- The next two fields are only valid after renaming - , recS_later_ids :: [IdP idR] - -- The ids are a subset of the variables bound by the - -- stmts that are used in stmts that follow the RecStmt - - , recS_rec_ids :: [IdP idR] - -- Ditto, but these variables are the "recursive" ones, - -- that are used before they are bound in the stmts of - -- the RecStmt. - -- An Id can be in both groups - -- Both sets of Ids are (now) treated monomorphically - -- See Note [How RecStmt works] for why they are separate - - -- Rebindable syntax - , recS_bind_fn :: SyntaxExpr idR -- The bind function - , recS_ret_fn :: SyntaxExpr idR -- The return function - , recS_mfix_fn :: SyntaxExpr idR -- The mfix function - } - | XStmtLR (XXStmtLR idL idR body) - --- Extra fields available post typechecking for RecStmt. -data RecStmtTc = - RecStmtTc - { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T - , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) - , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 - -- with recS_later_ids and recS_rec_ids, - -- and are the expressions that should be - -- returned by the recursion. - -- They may not quite be the Ids themselves, - -- because the Id may be *polymorphic*, but - -- the returned thing has to be *monomorphic*, - -- so they may be type applications - - , recS_ret_ty :: Type -- The type of - -- do { stmts; return (a,b,c) } - -- With rebindable syntax the type might not - -- be quite as simple as (m (tya, tyb, tyc)). - } - - -type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField - -type instance XBindStmt (GhcPass _) GhcPs b = NoExtField -type instance XBindStmt (GhcPass _) GhcRn b = NoExtField -type instance XBindStmt (GhcPass _) GhcTc b = Type - -type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField -type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField -type instance XApplicativeStmt (GhcPass _) GhcTc b = Type - -type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField -type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField -type instance XBodyStmt (GhcPass _) GhcTc b = Type - -type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExtField - -type instance XParStmt (GhcPass _) GhcPs b = NoExtField -type instance XParStmt (GhcPass _) GhcRn b = NoExtField -type instance XParStmt (GhcPass _) GhcTc b = Type - -type instance XTransStmt (GhcPass _) GhcPs b = NoExtField -type instance XTransStmt (GhcPass _) GhcRn b = NoExtField -type instance XTransStmt (GhcPass _) GhcTc b = Type - -type instance XRecStmt (GhcPass _) GhcPs b = NoExtField -type instance XRecStmt (GhcPass _) GhcRn b = NoExtField -type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc - -type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon - -data TransForm -- The 'f' below is the 'using' function, 'e' is the by function - = ThenForm -- then f or then f by e (depending on trS_by) - | GroupForm -- then group using f or then group by e using f (depending on trS_by) - deriving Data - --- | Parenthesised Statement Block -data ParStmtBlock idL idR - = ParStmtBlock - (XParStmtBlock idL idR) - [ExprLStmt idL] - [IdP idR] -- The variables to be returned - (SyntaxExpr idR) -- The return operator - | XParStmtBlock (XXParStmtBlock idL idR) - -type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField -type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon - --- | Applicative Argument -data ApplicativeArg idL - = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) - (XApplicativeArgOne idL) - (LPat idL) -- WildPat if it was a BodyStmt (see below) - (LHsExpr idL) - Bool -- True <=> was a BodyStmt - -- False <=> was a BindStmt - -- See Note [Applicative BodyStmt] - - | ApplicativeArgMany -- do { stmts; return vars } - (XApplicativeArgMany idL) - [ExprLStmt idL] -- stmts - (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) - (LPat idL) -- (v1,...,vn) - | XApplicativeArg (XXApplicativeArg idL) - -type instance XApplicativeArgOne (GhcPass _) = NoExtField -type instance XApplicativeArgMany (GhcPass _) = NoExtField -type instance XXApplicativeArg (GhcPass _) = NoExtCon - -{- -Note [The type of bind in Stmts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some Stmts, notably BindStmt, keep the (>>=) bind operator. -We do NOT assume that it has type - (>>=) :: m a -> (a -> m b) -> m b -In some cases (see #303, #1537) it might have a more -exotic type, such as - (>>=) :: m i j a -> (a -> m j k b) -> m i k b -So we must be careful not to make assumptions about the type. -In particular, the monad may not be uniform throughout. - -Note [TransStmt binder map] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The [(idR,idR)] in a TransStmt behaves as follows: - - * Before renaming: [] - - * After renaming: - [ (x27,x27), ..., (z35,z35) ] - These are the variables - bound by the stmts to the left of the 'group' - and used either in the 'by' clause, - or in the stmts following the 'group' - Each item is a pair of identical variables. - - * After typechecking: - [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] - Each pair has the same unique, but different *types*. - -Note [BodyStmt] -~~~~~~~~~~~~~~~ -BodyStmts are a bit tricky, because what they mean -depends on the context. Consider the following contexts: - - A do expression of type (m res_ty) - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E any_ty: do { ....; E; ... } - E :: m any_ty - Translation: E >> ... - - A list comprehensions of type [elt_ty] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E Bool: [ .. | .... E ] - [ .. | ..., E, ... ] - [ .. | .... | ..., E | ... ] - E :: Bool - Translation: if E then fail else ... - - A guard list, guarding a RHS of type rhs_ty - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... - E :: Bool - Translation: if E then fail else ... - - A monad comprehension of type (m res_ty) - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * BodyStmt E Bool: [ .. | .... E ] - E :: Bool - Translation: guard E >> ... - -Array comprehensions are handled like list comprehensions. - -Note [How RecStmt works] -~~~~~~~~~~~~~~~~~~~~~~~~ -Example: - HsDo [ BindStmt x ex - - , RecStmt { recS_rec_ids = [a, c] - , recS_stmts = [ BindStmt b (return (a,c)) - , LetStmt a = ...b... - , BindStmt c ec ] - , recS_later_ids = [a, b] - - , return (a b) ] - -Here, the RecStmt binds a,b,c; but - - Only a,b are used in the stmts *following* the RecStmt, - - Only a,c are used in the stmts *inside* the RecStmt - *before* their bindings - -Why do we need *both* rec_ids and later_ids? For monads they could be -combined into a single set of variables, but not for arrows. That -follows from the types of the respective feedback operators: - - mfix :: MonadFix m => (a -> m a) -> m a - loop :: ArrowLoop a => a (b,d) (c,d) -> a b c - -* For mfix, the 'a' covers the union of the later_ids and the rec_ids -* For 'loop', 'c' is the later_ids and 'd' is the rec_ids - -Note [Typing a RecStmt] -~~~~~~~~~~~~~~~~~~~~~~~ -A (RecStmt stmts) types as if you had written - - (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> - do { stmts - ; return (v1,..vn, r1, ..., rm) }) - -where v1..vn are the later_ids - r1..rm are the rec_ids - -Note [Monad Comprehensions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Monad comprehensions require separate functions like 'return' and -'>>=' for desugaring. These functions are stored in the statements -used in monad comprehensions. For example, the 'return' of the 'LastStmt' -expression is used to lift the body of the monad comprehension: - - [ body | stmts ] - => - stmts >>= \bndrs -> return body - -In transform and grouping statements ('then ..' and 'then group ..') the -'return' function is required for nested monad comprehensions, for example: - - [ body | stmts, then f, rest ] - => - f [ env | stmts ] >>= \bndrs -> [ body | rest ] - -BodyStmts require the 'Control.Monad.guard' function for boolean -expressions: - - [ body | exp, stmts ] - => - guard exp >> [ body | stmts ] - -Parallel statements require the 'Control.Monad.Zip.mzip' function: - - [ body | stmts1 | stmts2 | .. ] - => - mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body - -In any other context than 'MonadComp', the fields for most of these -'SyntaxExpr's stay bottom. - - -Note [Applicative BodyStmt] - -(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt -as if it was a BindStmt with a wildcard pattern. For example, - - do - x <- A - B - return x - -is transformed as if it were - - do - x <- A - _ <- B - return x - -so it transforms to - - (\(x,_) -> x) <$> A <*> B - -But we have to remember when we treat a BodyStmt like a BindStmt, -because in error messages we want to emit the original syntax the user -wrote, not our internal representation. So ApplicativeArgOne has a -Bool flag that is True when the original statement was a BodyStmt, so -that we can pretty-print it correctly. --} - -instance (Outputable (StmtLR idL idL (LHsExpr idL)), - Outputable (XXParStmtBlock idL idR)) - => Outputable (ParStmtBlock idL idR) where - ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts - ppr (XParStmtBlock x) = ppr x - -instance (idL ~ GhcPass pl,idR ~ GhcPass pr, - OutputableBndrId idL, OutputableBndrId idR, - Outputable body) - => Outputable (StmtLR idL idR body) where - ppr stmt = pprStmt stmt - -pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), - Outputable body) - => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc -pprStmt (LastStmt _ expr ret_stripped _) - = whenPprDebug (text "[last]") <+> - (if ret_stripped then text "return" else empty) <+> - ppr expr -pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr] -pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] -pprStmt (BodyStmt _ expr _ _) = ppr expr -pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) - -pprStmt (TransStmt { trS_stmts = stmts, trS_by = by - , trS_using = using, trS_form = form }) - = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) - -pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids - , recS_later_ids = later_ids }) - = text "rec" <+> - vcat [ ppr_do_stmts segment - , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids - , text "later_ids=" <> ppr later_ids])] - -pprStmt (ApplicativeStmt _ args mb_join) - = getPprStyle $ \style -> - if userStyle style - then pp_for_user - else pp_debug - where - -- make all the Applicative stuff invisible in error messages by - -- flattening the whole ApplicativeStmt nest back to a sequence - -- of statements. - pp_for_user = vcat $ concatMap flattenArg args - - -- ppr directly rather than transforming here, because we need to - -- inject a "return" which is hard when we're polymorphic in the id - -- type. - flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] - flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args - flattenStmt stmt = [ppr stmt] - - flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] - flattenArg (_, ApplicativeArgOne _ pat expr isBody) - | isBody = -- See Note [Applicative BodyStmt] - [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL))] - | otherwise = - [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL))] - flattenArg (_, ApplicativeArgMany _ stmts _ _) = - concatMap flattenStmt stmts - flattenArg (_, XApplicativeArg nec) = noExtCon nec - - pp_debug = - let - ap_expr = sep (punctuate (text " |") (map pp_arg args)) - in - if isNothing mb_join - then ap_expr - else text "join" <+> parens ap_expr - - pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc - pp_arg (_, ApplicativeArgOne _ pat expr isBody) - | isBody = -- See Note [Applicative BodyStmt] - ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL)) - | otherwise = - ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr - :: ExprStmt (GhcPass idL)) - pp_arg (_, ApplicativeArgMany _ stmts return pat) = - ppr pat <+> - text "<-" <+> - ppr (HsDo (panic "pprStmt") DoExpr (noLoc - (stmts ++ - [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)]))) - pp_arg (_, XApplicativeArg x) = ppr x - -pprStmt (XStmtLR x) = ppr x - -pprTransformStmt :: (OutputableBndrId (GhcPass p)) - => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) - -> Maybe (LHsExpr (GhcPass p)) -> SDoc -pprTransformStmt bndrs using by - = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) - , nest 2 (ppr using) - , nest 2 (pprBy by)] - -pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc -pprTransStmt by using ThenForm - = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] -pprTransStmt by using GroupForm - = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] - -pprBy :: Outputable body => Maybe body -> SDoc -pprBy Nothing = empty -pprBy (Just e) = text "by" <+> ppr e - -pprDo :: (OutputableBndrId (GhcPass p), Outputable body) - => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc -pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts -pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts -pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts -pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts -pprDo ListComp stmts = brackets $ pprComp stmts -pprDo MonadComp stmts = brackets $ pprComp stmts -pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt - -ppr_do_stmts :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), - Outputable body) - => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc --- Print a bunch of do stmts -ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) - -pprComp :: (OutputableBndrId (GhcPass p), Outputable body) - => [LStmt (GhcPass p) body] -> SDoc -pprComp quals -- Prints: body | qual1, ..., qualn - | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals - = if null initStmts - -- If there are no statements in a list comprehension besides the last - -- one, we simply treat it like a normal list. This does arise - -- occasionally in code that GHC generates, e.g., in implementations of - -- 'range' for derived 'Ix' instances for product datatypes with exactly - -- one constructor (e.g., see #12583). - then ppr body - else hang (ppr body <+> vbar) 2 (pprQuals initStmts) - | otherwise - = pprPanic "pprComp" (pprQuals quals) - -pprQuals :: (OutputableBndrId (GhcPass p), Outputable body) - => [LStmt (GhcPass p) body] -> SDoc --- Show list comprehension qualifiers separated by commas -pprQuals quals = interpp'SP quals - -{- -************************************************************************ -* * - Template Haskell quotation brackets -* * -************************************************************************ --} - --- | Haskell Splice -data HsSplice id - = HsTypedSplice -- $$z or $$(f 4) - (XTypedSplice id) - SpliceDecoration -- Whether $$( ) variant found, for pretty printing - (IdP id) -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsUntypedSplice -- $z or $(f 4) - (XUntypedSplice id) - SpliceDecoration -- Whether $( ) variant found, for pretty printing - (IdP id) -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice - (XQuasiQuote id) - (IdP id) -- Splice point - (IdP id) -- Quoter - SrcSpan -- The span of the enclosed string - FastString -- The enclosed string - - -- AZ:TODO: use XSplice instead of HsSpliced - | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in - -- RnSplice. - -- This is the result of splicing a splice. It is produced by - -- the renamer and consumed by the typechecker. It lives only - -- between the two. - (XSpliced id) - ThModFinalizers -- TH finalizers produced by the splice. - (HsSplicedThing id) -- The result of splicing - | HsSplicedT - DelayedSplice - | XSplice (XXSplice id) -- Note [Trees that Grow] extension point - -type instance XTypedSplice (GhcPass _) = NoExtField -type instance XUntypedSplice (GhcPass _) = NoExtField -type instance XQuasiQuote (GhcPass _) = NoExtField -type instance XSpliced (GhcPass _) = NoExtField -type instance XXSplice (GhcPass _) = NoExtCon - --- | A splice can appear with various decorations wrapped around it. This data --- type captures explicitly how it was originally written, for use in the pretty --- printer. -data SpliceDecoration - = HasParens -- ^ $( splice ) or $$( splice ) - | HasDollar -- ^ $splice or $$splice - | NoParens -- ^ bare splice - deriving (Data, Eq, Show) - -instance Outputable SpliceDecoration where - ppr x = text $ show x - - -isTypedSplice :: HsSplice id -> Bool -isTypedSplice (HsTypedSplice {}) = True -isTypedSplice _ = False -- Quasi-quotes are untyped splices - --- | Finalizers produced by a splice with --- 'Language.Haskell.TH.Syntax.addModFinalizer' --- --- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how --- this is used. --- -newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] - --- A Data instance which ignores the argument of 'ThModFinalizers'. -instance Data ThModFinalizers where - gunfold _ z _ = z $ ThModFinalizers [] - toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix - dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] - --- See Note [Running typed splices in the zonker] --- These are the arguments that are passed to `TcSplice.runTopSplice` -data DelayedSplice = - DelayedSplice - TcLclEnv -- The local environment to run the splice in - (LHsExpr GhcRn) -- The original renamed expression - TcType -- The result type of running the splice, unzonked - (LHsExpr GhcTcId) -- The typechecked expression to run and splice in the result - --- A Data instance which ignores the argument of 'DelayedSplice'. -instance Data DelayedSplice where - gunfold _ _ _ = panic "DelayedSplice" - toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix - dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] - --- | Haskell Spliced Thing --- --- Values that can result from running a splice. -data HsSplicedThing id - = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression - | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type - | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern - - --- See Note [Pending Splices] -type SplicePointName = Name - --- | Pending Renamer Splice -data PendingRnSplice - = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) - -data UntypedSpliceFlavour - = UntypedExpSplice - | UntypedPatSplice - | UntypedTypeSplice - | UntypedDeclSplice - deriving Data - --- | Pending Type-checker Splice -data PendingTcSplice - = PendingTcSplice SplicePointName (LHsExpr GhcTc) - -{- -Note [Pending Splices] -~~~~~~~~~~~~~~~~~~~~~~ -When we rename an untyped bracket, we name and lift out all the nested -splices, so that when the typechecker hits the bracket, it can -typecheck those nested splices without having to walk over the untyped -bracket code. So for example - [| f $(g x) |] -looks like - - HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) - -which the renamer rewrites to - - HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) - [PendingRnSplice UntypedExpSplice sn (g x)] - -* The 'sn' is the Name of the splice point, the SplicePointName - -* The PendingRnExpSplice gives the splice that splice-point name maps to; - and the typechecker can now conveniently find these sub-expressions - -* The other copy of the splice, in the second argument of HsSpliceE - in the renamed first arg of HsRnBracketOut - is used only for pretty printing - -There are four varieties of pending splices generated by the renamer, -distinguished by their UntypedSpliceFlavour - - * Pending expression splices (UntypedExpSplice), e.g., - [|$(f x) + 2|] - - UntypedExpSplice is also used for - * quasi-quotes, where the pending expression expands to - $(quoter "...blah...") - (see RnSplice.makePending, HsQuasiQuote case) - - * cross-stage lifting, where the pending expression expands to - $(lift x) - (see RnSplice.checkCrossStageLifting) - - * Pending pattern splices (UntypedPatSplice), e.g., - [| \$(f x) -> x |] - - * Pending type splices (UntypedTypeSplice), e.g., - [| f :: $(g x) |] - - * Pending declaration (UntypedDeclSplice), e.g., - [| let $(f x) in ... |] - -There is a fifth variety of pending splice, which is generated by the type -checker: - - * Pending *typed* expression splices, (PendingTcSplice), e.g., - [||1 + $$(f 2)||] - -It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the -output of the renamer. However, when pretty printing the output of the renamer, -e.g., in a type error message, we *do not* want to print out the pending -splices. In contrast, when pretty printing the output of the type checker, we -*do* want to print the pending splices. So splitting them up seems to make -sense, although I hate to add another constructor to HsExpr. --} - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsSplicedThing p) where - ppr (HsSplicedExpr e) = ppr_expr e - ppr (HsSplicedTy t) = ppr t - ppr (HsSplicedPat p) = ppr p - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsSplice p) where - ppr s = pprSplice s - -pprPendingSplice :: (OutputableBndrId (GhcPass p)) - => SplicePointName -> LHsExpr (GhcPass p) -> SDoc -pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) - -pprSpliceDecl :: (OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc -pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e -pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" -pprSpliceDecl e ImplicitSplice = ppr_splice_decl e - -ppr_splice_decl :: (OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SDoc -ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty -ppr_splice_decl e = pprSplice e - -pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc -pprSplice (HsTypedSplice _ HasParens n e) - = ppr_splice (text "$$(") n e (text ")") -pprSplice (HsTypedSplice _ HasDollar n e) - = ppr_splice (text "$$") n e empty -pprSplice (HsTypedSplice _ NoParens n e) - = ppr_splice empty n e empty -pprSplice (HsUntypedSplice _ HasParens n e) - = ppr_splice (text "$(") n e (text ")") -pprSplice (HsUntypedSplice _ HasDollar n e) - = ppr_splice (text "$") n e empty -pprSplice (HsUntypedSplice _ NoParens n e) - = ppr_splice empty n e empty -pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s -pprSplice (HsSpliced _ _ thing) = ppr thing -pprSplice (HsSplicedT {}) = text "Unevaluated typed splice" -pprSplice (XSplice x) = ppr x - -ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc -ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> - char '[' <> ppr quoter <> vbar <> - ppr quote <> text "|]" - -ppr_splice :: (OutputableBndrId (GhcPass p)) - => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc -ppr_splice herald n e trail - = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail - --- | Haskell Bracket -data HsBracket p - = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] - | PatBr (XPatBr p) (LPat p) -- [p| pat |] - | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser - | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer - | TypBr (XTypBr p) (LHsType p) -- [t| type |] - | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T - -- (The Bool flag is used only in pprHsBracket) - | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] - | XBracket (XXBracket p) -- Note [Trees that Grow] extension point - -type instance XExpBr (GhcPass _) = NoExtField -type instance XPatBr (GhcPass _) = NoExtField -type instance XDecBrL (GhcPass _) = NoExtField -type instance XDecBrG (GhcPass _) = NoExtField -type instance XTypBr (GhcPass _) = NoExtField -type instance XVarBr (GhcPass _) = NoExtField -type instance XTExpBr (GhcPass _) = NoExtField -type instance XXBracket (GhcPass _) = NoExtCon - -isTypedBracket :: HsBracket id -> Bool -isTypedBracket (TExpBr {}) = True -isTypedBracket _ = False - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsBracket p) where - ppr = pprHsBracket - - -pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc -pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) -pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) -pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) -pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) -pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr _ True n) - = char '\'' <> pprPrefixOcc n -pprHsBracket (VarBr _ False n) - = text "''" <> pprPrefixOcc n -pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) -pprHsBracket (XBracket e) = ppr e - -thBrackets :: SDoc -> SDoc -> SDoc -thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> - pp_body <+> text "|]" - -thTyBrackets :: SDoc -> SDoc -thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") - -instance Outputable PendingRnSplice where - ppr (PendingRnSplice _ n e) = pprPendingSplice n e - -instance Outputable PendingTcSplice where - ppr (PendingTcSplice n e) = pprPendingSplice n e - -{- -************************************************************************ -* * -\subsection{Enumerations and list comprehensions} -* * -************************************************************************ --} - --- | Arithmetic Sequence Information -data ArithSeqInfo id - = From (LHsExpr id) - | FromThen (LHsExpr id) - (LHsExpr id) - | FromTo (LHsExpr id) - (LHsExpr id) - | FromThenTo (LHsExpr id) - (LHsExpr id) - (LHsExpr id) --- AZ: Sould ArithSeqInfo have a TTG extension? - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (ArithSeqInfo p) where - ppr (From e1) = hcat [ppr e1, pp_dotdot] - ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] - ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] - ppr (FromThenTo e1 e2 e3) - = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] - -pp_dotdot :: SDoc -pp_dotdot = text " .. " - -{- -************************************************************************ -* * -\subsection{HsMatchCtxt} -* * -************************************************************************ --} - --- | Haskell Match Context --- --- Context of a pattern match. This is more subtle than it would seem. See Note --- [Varieties of pattern matches]. -data HsMatchContext id -- Not an extensible tag - = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ - , mc_fixity :: LexicalFixity -- ^ fixing of @f@ - , mc_strictness :: SrcStrictness -- ^ was @f@ banged? - -- See Note [FunBind vs PatBind] - } - -- ^A pattern matching on an argument of a - -- function binding - | LambdaExpr -- ^Patterns of a lambda - | CaseAlt -- ^Patterns and guards on a case alternative - | IfAlt -- ^Guards of a multi-way if alternative - | ProcExpr -- ^Patterns of a proc - | PatBindRhs -- ^A pattern binding eg [y] <- e = e - | PatBindGuards -- ^Guards of pattern bindings, e.g., - -- (Just b) | Just _ <- x = e - -- | otherwise = e' - - | RecUpd -- ^Record update [used only in DsExpr to - -- tell matchWrapper what sort of - -- runtime error message to generate] - - | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, - -- pattern guard, etc - - | ThPatSplice -- ^A Template Haskell pattern splice - | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] - | PatSyn -- ^A pattern synonym declaration - deriving Functor -deriving instance (Data id) => Data (HsMatchContext id) - -instance OutputableBndr id => Outputable (HsMatchContext id) where - ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) - ppr LambdaExpr = text "LambdaExpr" - ppr CaseAlt = text "CaseAlt" - ppr IfAlt = text "IfAlt" - ppr ProcExpr = text "ProcExpr" - ppr PatBindRhs = text "PatBindRhs" - ppr PatBindGuards = text "PatBindGuards" - ppr RecUpd = text "RecUpd" - ppr (StmtCtxt _) = text "StmtCtxt _" - ppr ThPatSplice = text "ThPatSplice" - ppr ThPatQuote = text "ThPatQuote" - ppr PatSyn = text "PatSyn" - -isPatSynCtxt :: HsMatchContext id -> Bool -isPatSynCtxt ctxt = - case ctxt of - PatSyn -> True - _ -> False - --- | Haskell Statement Context. It expects to be parameterised with one of --- 'RdrName', 'Name' or 'Id' -data HsStmtContext id - = ListComp - | MonadComp - - | DoExpr -- ^do { ... } - | MDoExpr -- ^mdo { ... } ie recursive do-expression - | ArrowExpr -- ^do-notation in an arrow-command context - - | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs - | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing - | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt - | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt - deriving Functor -deriving instance (Data id) => Data (HsStmtContext id) - -isComprehensionContext :: HsStmtContext id -> Bool --- Uses comprehension syntax [ e | quals ] -isComprehensionContext ListComp = True -isComprehensionContext MonadComp = True -isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c -isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c -isComprehensionContext _ = False - --- | Should pattern match failure in a 'HsStmtContext' be desugared using --- 'MonadFail'? -isMonadFailStmtContext :: HsStmtContext id -> Bool -isMonadFailStmtContext MonadComp = True -isMonadFailStmtContext DoExpr = True -isMonadFailStmtContext MDoExpr = True -isMonadFailStmtContext GhciStmtCtxt = True -isMonadFailStmtContext (ParStmtCtxt ctxt) = isMonadFailStmtContext ctxt -isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt -isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr - -isMonadCompContext :: HsStmtContext id -> Bool -isMonadCompContext MonadComp = True -isMonadCompContext _ = False - -matchSeparator :: HsMatchContext id -> SDoc -matchSeparator (FunRhs {}) = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator IfAlt = text "->" -matchSeparator LambdaExpr = text "->" -matchSeparator ProcExpr = text "->" -matchSeparator PatBindRhs = text "=" -matchSeparator PatBindGuards = text "=" -matchSeparator (StmtCtxt _) = text "<-" -matchSeparator RecUpd = text "=" -- This can be printed by the pattern - -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" -matchSeparator PatSyn = panic "unused" - -pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) - => HsMatchContext id -> SDoc -pprMatchContext ctxt - | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt - | otherwise = text "a" <+> pprMatchContextNoun ctxt - where - want_an (FunRhs {}) = True -- Use "an" in front - want_an ProcExpr = True - want_an _ = False - -pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) - => HsMatchContext id -> SDoc -pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) - = text "equation for" - <+> quotes (ppr fun) -pprMatchContextNoun CaseAlt = text "case alternative" -pprMatchContextNoun IfAlt = text "multi-way if alternative" -pprMatchContextNoun RecUpd = text "record-update construct" -pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" -pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" -pprMatchContextNoun PatBindRhs = text "pattern binding" -pprMatchContextNoun PatBindGuards = text "pattern binding guards" -pprMatchContextNoun LambdaExpr = text "lambda abstraction" -pprMatchContextNoun ProcExpr = text "arrow abstraction" -pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" - $$ pprAStmtContext ctxt -pprMatchContextNoun PatSyn = text "pattern synonym declaration" - ------------------ -pprAStmtContext, pprStmtContext :: (Outputable id, - Outputable (NameOrRdrName id)) - => HsStmtContext id -> SDoc -pprAStmtContext ctxt = article <+> pprStmtContext ctxt - where - pp_an = text "an" - pp_a = text "a" - article = case ctxt of - MDoExpr -> pp_an - GhciStmtCtxt -> pp_an - _ -> pp_a - - ------------------ -pprStmtContext GhciStmtCtxt = text "interactive GHCi command" -pprStmtContext DoExpr = text "'do' block" -pprStmtContext MDoExpr = text "'mdo' block" -pprStmtContext ArrowExpr = text "'do' block in an arrow command" -pprStmtContext ListComp = text "list comprehension" -pprStmtContext MonadComp = text "monad comprehension" -pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt - --- Drop the inner contexts when reporting errors, else we get --- Unexpected transform statement --- in a transformed branch of --- transformed branch of --- transformed branch of monad comprehension -pprStmtContext (ParStmtCtxt c) = - ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) - (pprStmtContext c) -pprStmtContext (TransStmtCtxt c) = - ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) - (pprStmtContext c) - -instance (Outputable p, Outputable (NameOrRdrName p)) - => Outputable (HsStmtContext p) where - ppr = pprStmtContext - --- Used to generate the string for a *runtime* error message -matchContextErrString :: Outputable id - => HsMatchContext id -> SDoc -matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun -matchContextErrString CaseAlt = text "case" -matchContextErrString IfAlt = text "multi-way if" -matchContextErrString PatBindRhs = text "pattern binding" -matchContextErrString PatBindGuards = text "pattern binding guards" -matchContextErrString RecUpd = text "record update" -matchContextErrString LambdaExpr = text "lambda" -matchContextErrString ProcExpr = text "proc" -matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime -matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime -matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime -matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" -matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command" -matchContextErrString (StmtCtxt DoExpr) = text "'do' block" -matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block" -matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" -matchContextErrString (StmtCtxt ListComp) = text "list comprehension" -matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" - -pprMatchInCtxt :: (OutputableBndrId (GhcPass idR), - -- TODO:AZ these constraints do not make sense - Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), - Outputable body) - => Match (GhcPass idR) body -> SDoc -pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) - <> colon) - 4 (pprMatch match) - -pprStmtInCtxt :: (OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), - Outputable body) - => HsStmtContext (IdP (GhcPass idL)) - -> StmtLR (GhcPass idL) (GhcPass idR) body - -> SDoc -pprStmtInCtxt ctxt (LastStmt _ e _ _) - | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts" - = hang (text "In the expression:") 2 (ppr e) - -pprStmtInCtxt ctxt stmt - = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) - 2 (ppr_stmt stmt) - where - -- For Group and Transform Stmts, don't print the nested stmts! - ppr_stmt (TransStmt { trS_by = by, trS_using = using - , trS_form = form }) = pprTransStmt by using form - ppr_stmt stmt = pprStmt stmt diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot deleted file mode 100644 index 109e9814e5..0000000000 --- a/compiler/hsSyn/HsExpr.hs-boot +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE CPP, KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeFamilies #-} - -module HsExpr where - -import SrcLoc ( Located ) -import Outputable ( SDoc, Outputable ) -import {-# SOURCE #-} HsPat ( LPat ) -import BasicTypes ( SpliceExplicitFlag(..)) -import HsExtension ( OutputableBndrId, GhcPass ) - -type role HsExpr nominal -type role HsCmd nominal -type role MatchGroup nominal nominal -type role GRHSs nominal nominal -type role HsSplice nominal -type role SyntaxExpr nominal -data HsExpr (i :: *) -data HsCmd (i :: *) -data HsSplice (i :: *) -data MatchGroup (a :: *) (body :: *) -data GRHSs (a :: *) (body :: *) -data SyntaxExpr (i :: *) - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) - -type LHsExpr a = Located (HsExpr a) - -pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc - -pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc - -pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc - -pprSpliceDecl :: (OutputableBndrId (GhcPass p)) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc - -pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr), - OutputableBndrId (GhcPass p), - Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc - -pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs deleted file mode 100644 index c486ad8a11..0000000000 --- a/compiler/hsSyn/HsExtension.hs +++ /dev/null @@ -1,1168 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder - -module HsExtension where - --- This module captures the type families to precisely identify the extension --- points for HsSyn - -import GhcPrelude - -import Data.Data hiding ( Fixity ) -import PlaceHolder -import Name -import RdrName -import Var -import Outputable -import SrcLoc (Located) - -import Data.Kind - -{- -Note [Trees that grow] -~~~~~~~~~~~~~~~~~~~~~~ - -See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow - -The hsSyn AST is reused across multiple compiler passes. We also have the -Template Haskell AST, and the haskell-src-exts one (outside of GHC) - -Supporting multiple passes means the AST has various warts on it to cope with -the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut', -'SigPatOut' etc. - -The growable AST will allow each of these variants to be captured explicitly, -such that they only exist in the given compiler pass AST, as selected by the -type parameter to the AST. - -In addition it will allow tool writers to define their own extensions to capture -additional information for the tool, in a natural way. - -A further goal is to provide a means to harmonise the Template Haskell and -haskell-src-exts ASTs as well. - --} - --- | A placeholder type for TTG extension points that are not currently --- unused to represent any particular value. --- --- This should not be confused with 'NoExtCon', which are found in unused --- extension /constructors/ and therefore should never be inhabited. In --- contrast, 'NoExtField' is used in extension /points/ (e.g., as the field of --- some constructor), so it must have an inhabitant to construct AST passes --- that manipulate fields with that extension point as their type. -data NoExtField = NoExtField - deriving (Data,Eq,Ord) - -instance Outputable NoExtField where - ppr _ = text "NoExtField" - --- | Used when constructing a term with an unused extension point. -noExtField :: NoExtField -noExtField = NoExtField - --- | Used in TTG extension constructors that have yet to be extended with --- anything. If an extension constructor has 'NoExtCon' as its field, it is --- not intended to ever be constructed anywhere, and any function that consumes --- the extension constructor can eliminate it by way of 'noExtCon'. --- --- This should not be confused with 'NoExtField', which are found in unused --- extension /points/ (not /constructors/) and therefore can be inhabited. - --- See also [NoExtCon and strict fields]. -data NoExtCon - deriving (Data,Eq,Ord) - -instance Outputable NoExtCon where - ppr = noExtCon - --- | Eliminate a 'NoExtCon'. Much like 'Data.Void.absurd'. -noExtCon :: NoExtCon -> a -noExtCon x = case x of {} - -{- -Note [NoExtCon and strict fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, any unused TTG extension constructor will generally look like the -following: - - type instance XXHsDecl (GhcPass _) = NoExtCon - data HsDecl p - = ... - | XHsDecl (XXHsDecl p) - -This means that any function that wishes to consume an HsDecl will need to -have a case for XHsDecl. This might look like this: - - ex :: HsDecl GhcPs -> HsDecl GhcRn - ... - ex (XHsDecl nec) = noExtCon nec - -Ideally, we wouldn't need a case for XHsDecl at all (it /is/ supposed to be -an unused extension constructor, after all). There is a way to achieve this -on GHC 8.8 or later: make the field of XHsDecl strict: - - data HsDecl p - = ... - | XHsDecl !(XXHsDecl p) - -If this is done, GHC's pattern-match coverage checker is clever enough to -figure out that the XHsDecl case of `ex` is unreachable, so it can simply be -omitted. (See Note [Extensions to GADTs Meet Their Match] in Check for more on -how this works.) - -When GHC drops support for bootstrapping with GHC 8.6 and earlier, we can make -the strict field changes described above and delete gobs of code involving -`noExtCon`. Until then, it is necessary to use, so be aware of it when writing -code that consumes unused extension constructors. --} - --- | Used as a data type index for the hsSyn AST -data GhcPass (c :: Pass) -deriving instance Eq (GhcPass c) -deriving instance Typeable c => Data (GhcPass c) - -data Pass = Parsed | Renamed | Typechecked - deriving (Data) - --- Type synonyms as a shorthand for tagging -type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param -type GhcRn = GhcPass 'Renamed -- Old 'Name' type param -type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, -type GhcTcId = GhcTc -- Old 'TcId' type param - --- | Maps the "normal" id type for a given pass -type family IdP p -type instance IdP GhcPs = RdrName -type instance IdP GhcRn = Name -type instance IdP GhcTc = Id - -type LIdP p = Located (IdP p) - --- | Marks that a field uses the GhcRn variant even when the pass --- parameter is GhcTc. Useful for storing HsTypes in HsExprs, say, because --- HsType GhcTc should never occur. -type family NoGhcTc (p :: Type) where - -- this way, GHC can figure out that the result is a GhcPass - NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) - NoGhcTc other = other - -type family NoGhcTcPass (p :: Pass) :: Pass where - NoGhcTcPass 'Typechecked = 'Renamed - NoGhcTcPass other = other - --- ===================================================================== --- Type families for the HsBinds extension points - --- HsLocalBindsLR type families -type family XHsValBinds x x' -type family XHsIPBinds x x' -type family XEmptyLocalBinds x x' -type family XXHsLocalBindsLR x x' - -type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XHsValBinds x x') - , c (XHsIPBinds x x') - , c (XEmptyLocalBinds x x') - , c (XXHsLocalBindsLR x x') - ) - --- ValBindsLR type families -type family XValBinds x x' -type family XXValBindsLR x x' - -type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XValBinds x x') - , c (XXValBindsLR x x') - ) - - --- HsBindsLR type families -type family XFunBind x x' -type family XPatBind x x' -type family XVarBind x x' -type family XAbsBinds x x' -type family XPatSynBind x x' -type family XXHsBindsLR x x' - -type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XFunBind x x') - , c (XPatBind x x') - , c (XVarBind x x') - , c (XAbsBinds x x') - , c (XPatSynBind x x') - , c (XXHsBindsLR x x') - ) - --- ABExport type families -type family XABE x -type family XXABExport x - -type ForallXABExport (c :: * -> Constraint) (x :: *) = - ( c (XABE x) - , c (XXABExport x) - ) - --- PatSynBind type families -type family XPSB x x' -type family XXPatSynBind x x' - -type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XPSB x x') - , c (XXPatSynBind x x') - ) - --- HsIPBinds type families -type family XIPBinds x -type family XXHsIPBinds x - -type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) = - ( c (XIPBinds x) - , c (XXHsIPBinds x) - ) - --- IPBind type families -type family XCIPBind x -type family XXIPBind x - -type ForallXIPBind (c :: * -> Constraint) (x :: *) = - ( c (XCIPBind x) - , c (XXIPBind x) - ) - --- Sig type families -type family XTypeSig x -type family XPatSynSig x -type family XClassOpSig x -type family XIdSig x -type family XFixSig x -type family XInlineSig x -type family XSpecSig x -type family XSpecInstSig x -type family XMinimalSig x -type family XSCCFunSig x -type family XCompleteMatchSig x -type family XXSig x - -type ForallXSig (c :: * -> Constraint) (x :: *) = - ( c (XTypeSig x) - , c (XPatSynSig x) - , c (XClassOpSig x) - , c (XIdSig x) - , c (XFixSig x) - , c (XInlineSig x) - , c (XSpecSig x) - , c (XSpecInstSig x) - , c (XMinimalSig x) - , c (XSCCFunSig x) - , c (XCompleteMatchSig x) - , c (XXSig x) - ) - --- FixitySig type families -type family XFixitySig x -type family XXFixitySig x - -type ForallXFixitySig (c :: * -> Constraint) (x :: *) = - ( c (XFixitySig x) - , c (XXFixitySig x) - ) - --- ===================================================================== --- Type families for the HsDecls extension points - --- HsDecl type families -type family XTyClD x -type family XInstD x -type family XDerivD x -type family XValD x -type family XSigD x -type family XDefD x -type family XForD x -type family XWarningD x -type family XAnnD x -type family XRuleD x -type family XSpliceD x -type family XDocD x -type family XRoleAnnotD x -type family XXHsDecl x - -type ForallXHsDecl (c :: * -> Constraint) (x :: *) = - ( c (XTyClD x) - , c (XInstD x) - , c (XDerivD x) - , c (XValD x) - , c (XSigD x) - , c (XDefD x) - , c (XForD x) - , c (XWarningD x) - , c (XAnnD x) - , c (XRuleD x) - , c (XSpliceD x) - , c (XDocD x) - , c (XRoleAnnotD x) - , c (XXHsDecl x) - ) - --- ------------------------------------- --- HsGroup type families -type family XCHsGroup x -type family XXHsGroup x - -type ForallXHsGroup (c :: * -> Constraint) (x :: *) = - ( c (XCHsGroup x) - , c (XXHsGroup x) - ) - --- ------------------------------------- --- SpliceDecl type families -type family XSpliceDecl x -type family XXSpliceDecl x - -type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) = - ( c (XSpliceDecl x) - , c (XXSpliceDecl x) - ) - --- ------------------------------------- --- TyClDecl type families -type family XFamDecl x -type family XSynDecl x -type family XDataDecl x -type family XClassDecl x -type family XXTyClDecl x - -type ForallXTyClDecl (c :: * -> Constraint) (x :: *) = - ( c (XFamDecl x) - , c (XSynDecl x) - , c (XDataDecl x) - , c (XClassDecl x) - , c (XXTyClDecl x) - ) - --- ------------------------------------- --- TyClGroup type families -type family XCTyClGroup x -type family XXTyClGroup x - -type ForallXTyClGroup (c :: * -> Constraint) (x :: *) = - ( c (XCTyClGroup x) - , c (XXTyClGroup x) - ) - --- ------------------------------------- --- FamilyResultSig type families -type family XNoSig x -type family XCKindSig x -- Clashes with XKindSig above -type family XTyVarSig x -type family XXFamilyResultSig x - -type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) = - ( c (XNoSig x) - , c (XCKindSig x) - , c (XTyVarSig x) - , c (XXFamilyResultSig x) - ) - --- ------------------------------------- --- FamilyDecl type families -type family XCFamilyDecl x -type family XXFamilyDecl x - -type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) = - ( c (XCFamilyDecl x) - , c (XXFamilyDecl x) - ) - --- ------------------------------------- --- HsDataDefn type families -type family XCHsDataDefn x -type family XXHsDataDefn x - -type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) = - ( c (XCHsDataDefn x) - , c (XXHsDataDefn x) - ) - --- ------------------------------------- --- HsDerivingClause type families -type family XCHsDerivingClause x -type family XXHsDerivingClause x - -type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) = - ( c (XCHsDerivingClause x) - , c (XXHsDerivingClause x) - ) - --- ------------------------------------- --- ConDecl type families -type family XConDeclGADT x -type family XConDeclH98 x -type family XXConDecl x - -type ForallXConDecl (c :: * -> Constraint) (x :: *) = - ( c (XConDeclGADT x) - , c (XConDeclH98 x) - , c (XXConDecl x) - ) - --- ------------------------------------- --- FamEqn type families -type family XCFamEqn x r -type family XXFamEqn x r - -type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) = - ( c (XCFamEqn x r) - , c (XXFamEqn x r) - ) - --- ------------------------------------- --- ClsInstDecl type families -type family XCClsInstDecl x -type family XXClsInstDecl x - -type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) = - ( c (XCClsInstDecl x) - , c (XXClsInstDecl x) - ) - --- ------------------------------------- --- ClsInstDecl type families -type family XClsInstD x -type family XDataFamInstD x -type family XTyFamInstD x -type family XXInstDecl x - -type ForallXInstDecl (c :: * -> Constraint) (x :: *) = - ( c (XClsInstD x) - , c (XDataFamInstD x) - , c (XTyFamInstD x) - , c (XXInstDecl x) - ) - --- ------------------------------------- --- DerivDecl type families -type family XCDerivDecl x -type family XXDerivDecl x - -type ForallXDerivDecl (c :: * -> Constraint) (x :: *) = - ( c (XCDerivDecl x) - , c (XXDerivDecl x) - ) - --- ------------------------------------- --- DerivStrategy type family -type family XViaStrategy x - --- ------------------------------------- --- DefaultDecl type families -type family XCDefaultDecl x -type family XXDefaultDecl x - -type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) = - ( c (XCDefaultDecl x) - , c (XXDefaultDecl x) - ) - --- ------------------------------------- --- DefaultDecl type families -type family XForeignImport x -type family XForeignExport x -type family XXForeignDecl x - -type ForallXForeignDecl (c :: * -> Constraint) (x :: *) = - ( c (XForeignImport x) - , c (XForeignExport x) - , c (XXForeignDecl x) - ) - --- ------------------------------------- --- RuleDecls type families -type family XCRuleDecls x -type family XXRuleDecls x - -type ForallXRuleDecls (c :: * -> Constraint) (x :: *) = - ( c (XCRuleDecls x) - , c (XXRuleDecls x) - ) - - --- ------------------------------------- --- RuleDecl type families -type family XHsRule x -type family XXRuleDecl x - -type ForallXRuleDecl (c :: * -> Constraint) (x :: *) = - ( c (XHsRule x) - , c (XXRuleDecl x) - ) - --- ------------------------------------- --- RuleBndr type families -type family XCRuleBndr x -type family XRuleBndrSig x -type family XXRuleBndr x - -type ForallXRuleBndr (c :: * -> Constraint) (x :: *) = - ( c (XCRuleBndr x) - , c (XRuleBndrSig x) - , c (XXRuleBndr x) - ) - --- ------------------------------------- --- WarnDecls type families -type family XWarnings x -type family XXWarnDecls x - -type ForallXWarnDecls (c :: * -> Constraint) (x :: *) = - ( c (XWarnings x) - , c (XXWarnDecls x) - ) - --- ------------------------------------- --- AnnDecl type families -type family XWarning x -type family XXWarnDecl x - -type ForallXWarnDecl (c :: * -> Constraint) (x :: *) = - ( c (XWarning x) - , c (XXWarnDecl x) - ) - --- ------------------------------------- --- AnnDecl type families -type family XHsAnnotation x -type family XXAnnDecl x - -type ForallXAnnDecl (c :: * -> Constraint) (x :: *) = - ( c (XHsAnnotation x) - , c (XXAnnDecl x) - ) - --- ------------------------------------- --- RoleAnnotDecl type families -type family XCRoleAnnotDecl x -type family XXRoleAnnotDecl x - -type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) = - ( c (XCRoleAnnotDecl x) - , c (XXRoleAnnotDecl x) - ) - --- ===================================================================== --- Type families for the HsExpr extension points - -type family XVar x -type family XUnboundVar x -type family XConLikeOut x -type family XRecFld x -type family XOverLabel x -type family XIPVar x -type family XOverLitE x -type family XLitE x -type family XLam x -type family XLamCase x -type family XApp x -type family XAppTypeE x -type family XOpApp x -type family XNegApp x -type family XPar x -type family XSectionL x -type family XSectionR x -type family XExplicitTuple x -type family XExplicitSum x -type family XCase x -type family XIf x -type family XMultiIf x -type family XLet x -type family XDo x -type family XExplicitList x -type family XRecordCon x -type family XRecordUpd x -type family XExprWithTySig x -type family XArithSeq x -type family XSCC x -type family XCoreAnn x -type family XBracket x -type family XRnBracketOut x -type family XTcBracketOut x -type family XSpliceE x -type family XProc x -type family XStatic x -type family XTick x -type family XBinTick x -type family XTickPragma x -type family XWrap x -type family XXExpr x - -type ForallXExpr (c :: * -> Constraint) (x :: *) = - ( c (XVar x) - , c (XUnboundVar x) - , c (XConLikeOut x) - , c (XRecFld x) - , c (XOverLabel x) - , c (XIPVar x) - , c (XOverLitE x) - , c (XLitE x) - , c (XLam x) - , c (XLamCase x) - , c (XApp x) - , c (XAppTypeE x) - , c (XOpApp x) - , c (XNegApp x) - , c (XPar x) - , c (XSectionL x) - , c (XSectionR x) - , c (XExplicitTuple x) - , c (XExplicitSum x) - , c (XCase x) - , c (XIf x) - , c (XMultiIf x) - , c (XLet x) - , c (XDo x) - , c (XExplicitList x) - , c (XRecordCon x) - , c (XRecordUpd x) - , c (XExprWithTySig x) - , c (XArithSeq x) - , c (XSCC x) - , c (XCoreAnn x) - , c (XBracket x) - , c (XRnBracketOut x) - , c (XTcBracketOut x) - , c (XSpliceE x) - , c (XProc x) - , c (XStatic x) - , c (XTick x) - , c (XBinTick x) - , c (XTickPragma x) - , c (XWrap x) - , c (XXExpr x) - ) --- --------------------------------------------------------------------- - -type family XUnambiguous x -type family XAmbiguous x -type family XXAmbiguousFieldOcc x - -type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XUnambiguous x) - , c (XAmbiguous x) - , c (XXAmbiguousFieldOcc x) - ) - --- ---------------------------------------------------------------------- - -type family XPresent x -type family XMissing x -type family XXTupArg x - -type ForallXTupArg (c :: * -> Constraint) (x :: *) = - ( c (XPresent x) - , c (XMissing x) - , c (XXTupArg x) - ) - --- --------------------------------------------------------------------- - -type family XTypedSplice x -type family XUntypedSplice x -type family XQuasiQuote x -type family XSpliced x -type family XXSplice x - -type ForallXSplice (c :: * -> Constraint) (x :: *) = - ( c (XTypedSplice x) - , c (XUntypedSplice x) - , c (XQuasiQuote x) - , c (XSpliced x) - , c (XXSplice x) - ) - --- --------------------------------------------------------------------- - -type family XExpBr x -type family XPatBr x -type family XDecBrL x -type family XDecBrG x -type family XTypBr x -type family XVarBr x -type family XTExpBr x -type family XXBracket x - -type ForallXBracket (c :: * -> Constraint) (x :: *) = - ( c (XExpBr x) - , c (XPatBr x) - , c (XDecBrL x) - , c (XDecBrG x) - , c (XTypBr x) - , c (XVarBr x) - , c (XTExpBr x) - , c (XXBracket x) - ) - --- --------------------------------------------------------------------- - -type family XCmdTop x -type family XXCmdTop x - -type ForallXCmdTop (c :: * -> Constraint) (x :: *) = - ( c (XCmdTop x) - , c (XXCmdTop x) - ) - --- ------------------------------------- - -type family XMG x b -type family XXMatchGroup x b - -type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XMG x b) - , c (XXMatchGroup x b) - ) - --- ------------------------------------- - -type family XCMatch x b -type family XXMatch x b - -type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCMatch x b) - , c (XXMatch x b) - ) - --- ------------------------------------- - -type family XCGRHSs x b -type family XXGRHSs x b - -type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCGRHSs x b) - , c (XXGRHSs x b) - ) - --- ------------------------------------- - -type family XCGRHS x b -type family XXGRHS x b - -type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XCGRHS x b) - , c (XXGRHS x b) - ) - --- ------------------------------------- - -type family XLastStmt x x' b -type family XBindStmt x x' b -type family XApplicativeStmt x x' b -type family XBodyStmt x x' b -type family XLetStmt x x' b -type family XParStmt x x' b -type family XTransStmt x x' b -type family XRecStmt x x' b -type family XXStmtLR x x' b - -type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) = - ( c (XLastStmt x x' b) - , c (XBindStmt x x' b) - , c (XApplicativeStmt x x' b) - , c (XBodyStmt x x' b) - , c (XLetStmt x x' b) - , c (XParStmt x x' b) - , c (XTransStmt x x' b) - , c (XRecStmt x x' b) - , c (XXStmtLR x x' b) - ) - --- --------------------------------------------------------------------- - -type family XCmdArrApp x -type family XCmdArrForm x -type family XCmdApp x -type family XCmdLam x -type family XCmdPar x -type family XCmdCase x -type family XCmdIf x -type family XCmdLet x -type family XCmdDo x -type family XCmdWrap x -type family XXCmd x - -type ForallXCmd (c :: * -> Constraint) (x :: *) = - ( c (XCmdArrApp x) - , c (XCmdArrForm x) - , c (XCmdApp x) - , c (XCmdLam x) - , c (XCmdPar x) - , c (XCmdCase x) - , c (XCmdIf x) - , c (XCmdLet x) - , c (XCmdDo x) - , c (XCmdWrap x) - , c (XXCmd x) - ) - --- --------------------------------------------------------------------- - -type family XParStmtBlock x x' -type family XXParStmtBlock x x' - -type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = - ( c (XParStmtBlock x x') - , c (XXParStmtBlock x x') - ) - --- --------------------------------------------------------------------- - -type family XApplicativeArgOne x -type family XApplicativeArgMany x -type family XXApplicativeArg x - -type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) = - ( c (XApplicativeArgOne x) - , c (XApplicativeArgMany x) - , c (XXApplicativeArg x) - ) - --- ===================================================================== --- Type families for the HsImpExp extension points - --- TODO - --- ===================================================================== --- Type families for the HsLit extension points - --- We define a type family for each extension point. This is based on prepending --- 'X' to the constructor name, for ease of reference. -type family XHsChar x -type family XHsCharPrim x -type family XHsString x -type family XHsStringPrim x -type family XHsInt x -type family XHsIntPrim x -type family XHsWordPrim x -type family XHsInt64Prim x -type family XHsWord64Prim x -type family XHsInteger x -type family XHsRat x -type family XHsFloatPrim x -type family XHsDoublePrim x -type family XXLit x - --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXHsLit (c :: * -> Constraint) (x :: *) = - ( c (XHsChar x) - , c (XHsCharPrim x) - , c (XHsDoublePrim x) - , c (XHsFloatPrim x) - , c (XHsInt x) - , c (XHsInt64Prim x) - , c (XHsIntPrim x) - , c (XHsInteger x) - , c (XHsRat x) - , c (XHsString x) - , c (XHsStringPrim x) - , c (XHsWord64Prim x) - , c (XHsWordPrim x) - , c (XXLit x) - ) - -type family XOverLit x -type family XXOverLit x - -type ForallXOverLit (c :: * -> Constraint) (x :: *) = - ( c (XOverLit x) - , c (XXOverLit x) - ) - --- ===================================================================== --- Type families for the HsPat extension points - -type family XWildPat x -type family XVarPat x -type family XLazyPat x -type family XAsPat x -type family XParPat x -type family XBangPat x -type family XListPat x -type family XTuplePat x -type family XSumPat x -type family XConPat x -type family XViewPat x -type family XSplicePat x -type family XLitPat x -type family XNPat x -type family XNPlusKPat x -type family XSigPat x -type family XCoPat x -type family XXPat x - - -type ForallXPat (c :: * -> Constraint) (x :: *) = - ( c (XWildPat x) - , c (XVarPat x) - , c (XLazyPat x) - , c (XAsPat x) - , c (XParPat x) - , c (XBangPat x) - , c (XListPat x) - , c (XTuplePat x) - , c (XSumPat x) - , c (XViewPat x) - , c (XSplicePat x) - , c (XLitPat x) - , c (XNPat x) - , c (XNPlusKPat x) - , c (XSigPat x) - , c (XCoPat x) - , c (XXPat x) - ) - --- ===================================================================== --- Type families for the HsTypes type families - -type family XHsQTvs x -type family XXLHsQTyVars x - -type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) = - ( c (XHsQTvs x) - , c (XXLHsQTyVars x) - ) - --- ------------------------------------- - -type family XHsIB x b -type family XXHsImplicitBndrs x b - -type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XHsIB x b) - , c (XXHsImplicitBndrs x b) - ) - --- ------------------------------------- - -type family XHsWC x b -type family XXHsWildCardBndrs x b - -type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) = - ( c (XHsWC x b) - , c (XXHsWildCardBndrs x b) - ) - --- ------------------------------------- - -type family XForAllTy x -type family XQualTy x -type family XTyVar x -type family XAppTy x -type family XAppKindTy x -type family XFunTy x -type family XListTy x -type family XTupleTy x -type family XSumTy x -type family XOpTy x -type family XParTy x -type family XIParamTy x -type family XStarTy x -type family XKindSig x -type family XSpliceTy x -type family XDocTy x -type family XBangTy x -type family XRecTy x -type family XExplicitListTy x -type family XExplicitTupleTy x -type family XTyLit x -type family XWildCardTy x -type family XXType x - --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXType (c :: * -> Constraint) (x :: *) = - ( c (XForAllTy x) - , c (XQualTy x) - , c (XTyVar x) - , c (XAppTy x) - , c (XAppKindTy x) - , c (XFunTy x) - , c (XListTy x) - , c (XTupleTy x) - , c (XSumTy x) - , c (XOpTy x) - , c (XParTy x) - , c (XIParamTy x) - , c (XStarTy x) - , c (XKindSig x) - , c (XSpliceTy x) - , c (XDocTy x) - , c (XBangTy x) - , c (XRecTy x) - , c (XExplicitListTy x) - , c (XExplicitTupleTy x) - , c (XTyLit x) - , c (XWildCardTy x) - , c (XXType x) - ) - --- --------------------------------------------------------------------- - -type family XUserTyVar x -type family XKindedTyVar x -type family XXTyVarBndr x - -type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = - ( c (XUserTyVar x) - , c (XKindedTyVar x) - , c (XXTyVarBndr x) - ) - --- --------------------------------------------------------------------- - -type family XConDeclField x -type family XXConDeclField x - -type ForallXConDeclField (c :: * -> Constraint) (x :: *) = - ( c (XConDeclField x) - , c (XXConDeclField x) - ) - --- --------------------------------------------------------------------- - -type family XCFieldOcc x -type family XXFieldOcc x - -type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XCFieldOcc x) - , c (XXFieldOcc x) - ) - - --- ===================================================================== --- Type families for the HsImpExp type families - -type family XCImportDecl x -type family XXImportDecl x - -type ForallXImportDecl (c :: * -> Constraint) (x :: *) = - ( c (XCImportDecl x) - , c (XXImportDecl x) - ) - --- ------------------------------------- - -type family XIEVar x -type family XIEThingAbs x -type family XIEThingAll x -type family XIEThingWith x -type family XIEModuleContents x -type family XIEGroup x -type family XIEDoc x -type family XIEDocNamed x -type family XXIE x - -type ForallXIE (c :: * -> Constraint) (x :: *) = - ( c (XIEVar x) - , c (XIEThingAbs x) - , c (XIEThingAll x) - , c (XIEThingWith x) - , c (XIEModuleContents x) - , c (XIEGroup x) - , c (XIEDoc x) - , c (XIEDocNamed x) - , c (XXIE x) - ) - --- ------------------------------------- - - --- ===================================================================== --- End of Type family definitions --- ===================================================================== - --- ---------------------------------------------------------------------- --- | Conversion of annotations from one type index to another. This is required --- where the AST is converted from one pass to another, and the extension values --- need to be brought along if possible. So for example a 'SourceText' is --- converted via 'id', but needs a type signature to keep the type checker --- happy. -class Convertable a b | a -> b where - convert :: a -> b - -instance Convertable a a where - convert = id - --- | A constraint capturing all the extension points that can be converted via --- @instance Convertable a a@ -type ConvertIdX a b = - (XHsDoublePrim a ~ XHsDoublePrim b, - XHsFloatPrim a ~ XHsFloatPrim b, - XHsRat a ~ XHsRat b, - XHsInteger a ~ XHsInteger b, - XHsWord64Prim a ~ XHsWord64Prim b, - XHsInt64Prim a ~ XHsInt64Prim b, - XHsWordPrim a ~ XHsWordPrim b, - XHsIntPrim a ~ XHsIntPrim b, - XHsInt a ~ XHsInt b, - XHsStringPrim a ~ XHsStringPrim b, - XHsString a ~ XHsString b, - XHsCharPrim a ~ XHsCharPrim b, - XHsChar a ~ XHsChar b, - XXLit a ~ XXLit b) - --- ---------------------------------------------------------------------- - --- Note [OutputableX] --- ~~~~~~~~~~~~~~~~~~ --- --- is required because the type family resolution --- process cannot determine that all cases are handled for a `GhcPass p` --- case where the cases are listed separately. --- --- So --- --- type instance XXHsIPBinds (GhcPass p) = NoExtCon --- --- will correctly deduce Outputable for (GhcPass p), but --- --- type instance XIPBinds GhcPs = NoExt --- type instance XIPBinds GhcRn = NoExt --- type instance XIPBinds GhcTc = TcEvBinds --- --- will not. - - --- | Provide a summary constraint that gives all am Outputable constraint to --- extension points needing one -type OutputableX p = -- See Note [OutputableX] - ( Outputable (XIPBinds p) - , Outputable (XViaStrategy p) - , Outputable (XViaStrategy GhcRn) - ) --- TODO: Should OutputableX be included in OutputableBndrId? - --- ---------------------------------------------------------------------- - --- |Constraint type to bundle up the requirement for 'OutputableBndr' on both --- the @id@ and the 'NameOrRdrName' type for it -type OutputableBndrId id = - ( OutputableBndr (NameOrRdrName (IdP id)) - , OutputableBndr (IdP id) - , OutputableBndr (NameOrRdrName (IdP (NoGhcTc id))) - , OutputableBndr (IdP (NoGhcTc id)) - , NoGhcTc id ~ NoGhcTc (NoGhcTc id) - , OutputableX id - , OutputableX (NoGhcTc id) - ) diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs deleted file mode 100644 index bedb74e05d..0000000000 --- a/compiler/hsSyn/HsImpExp.hs +++ /dev/null @@ -1,366 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -HsImpExp: Abstract syntax: imports, exports, interfaces --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder - -module HsImpExp where - -import GhcPrelude - -import Module ( ModuleName ) -import HsDoc ( HsDocString ) -import OccName ( HasOccName(..), isTcOcc, isSymOcc ) -import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) -import FieldLabel ( FieldLbl(..) ) - -import Outputable -import FastString -import SrcLoc -import HsExtension - -import Data.Data -import Data.Maybe - -{- -************************************************************************ -* * -\subsection{Import and export declaration lists} -* * -************************************************************************ - -One per \tr{import} declaration in a module. --} - --- | Located Import Declaration -type LImportDecl pass = Located (ImportDecl pass) - -- ^ When in a list this may have - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | If/how an import is 'qualified'. -data ImportDeclQualifiedStyle - = QualifiedPre -- ^ 'qualified' appears in prepositive position. - | QualifiedPost -- ^ 'qualified' appears in postpositive position. - | NotQualified -- ^ Not qualified. - deriving (Eq, Data) - --- | Given two possible located 'qualified' tokens, compute a style --- (in a conforming Haskell program only one of the two can be not --- 'Nothing'). This is called from 'Parser.y'. -importDeclQualifiedStyle :: Maybe (Located a) - -> Maybe (Located a) - -> ImportDeclQualifiedStyle -importDeclQualifiedStyle mPre mPost = - if isJust mPre then QualifiedPre - else if isJust mPost then QualifiedPost else NotQualified - --- | Convenience function to answer the question if an import decl. is --- qualified. -isImportDeclQualified :: ImportDeclQualifiedStyle -> Bool -isImportDeclQualified NotQualified = False -isImportDeclQualified _ = True - --- | Import Declaration --- --- A single Haskell @import@ declaration. -data ImportDecl pass - = ImportDecl { - ideclExt :: XCImportDecl pass, - ideclSourceSrc :: SourceText, - -- Note [Pragma source text] in BasicTypes - ideclName :: Located ModuleName, -- ^ Module name. - ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. - ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import - ideclSafe :: Bool, -- ^ True => safe import - ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. - ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) - ideclAs :: Maybe (Located ModuleName), -- ^ as Module - ideclHiding :: Maybe (Bool, Located [LIE pass]) - -- ^ (True => hiding, names) - } - | XImportDecl (XXImportDecl pass) - -- ^ - -- 'ApiAnnotation.AnnKeywordId's - -- - -- - 'ApiAnnotation.AnnImport' - -- - -- - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource - -- - -- - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified', - -- 'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs', - -- 'ApiAnnotation.AnnVal' - -- - -- - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose' attached - -- to location in ideclHiding - - -- For details on above see note [Api annotations] in ApiAnnotation - -type instance XCImportDecl (GhcPass _) = NoExtField -type instance XXImportDecl (GhcPass _) = NoExtCon - -simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p) -simpleImportDecl mn = ImportDecl { - ideclExt = noExtField, - ideclSourceSrc = NoSourceText, - ideclName = noLoc mn, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, - ideclImplicit = False, - ideclQualified = NotQualified, - ideclAs = Nothing, - ideclHiding = Nothing - } - -instance (p ~ GhcPass pass,OutputableBndrId p) - => Outputable (ImportDecl p) where - ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' - , ideclPkgQual = pkg - , ideclSource = from, ideclSafe = safe - , ideclQualified = qual, ideclImplicit = implicit - , ideclAs = as, ideclHiding = spec }) - = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe, - pp_qual qual False, pp_pkg pkg, ppr mod', pp_qual qual True, pp_as as]) - 4 (pp_spec spec) - where - pp_implicit False = empty - pp_implicit True = ptext (sLit ("(implicit)")) - - pp_pkg Nothing = empty - pp_pkg (Just (StringLiteral st p)) - = pprWithSourceText st (doubleQuotes (ftext p)) - - pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. - pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position. - pp_qual QualifiedPre True = empty -- Prepositive qualifier/postpositive position. - pp_qual QualifiedPost False = empty -- Postpositive qualifier/prepositive position. - pp_qual NotQualified _ = empty - - pp_safe False = empty - pp_safe True = text "safe" - - pp_as Nothing = empty - pp_as (Just a) = text "as" <+> ppr a - - ppr_imp True = case mSrcText of - NoSourceText -> text "{-# SOURCE #-}" - SourceText src -> text src <+> text "#-}" - ppr_imp False = empty - - pp_spec Nothing = empty - pp_spec (Just (False, (L _ ies))) = ppr_ies ies - pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies - - ppr_ies [] = text "()" - ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' - ppr (XImportDecl x) = ppr x - -{- -************************************************************************ -* * -\subsection{Imported and exported entities} -* * -************************************************************************ --} - --- | A name in an import or export specification which may have adornments. Used --- primarily for accurate pretty printing of ParsedSource, and API Annotation --- placement. -data IEWrappedName name - = IEName (Located name) -- ^ no extra - | IEPattern (Located name) -- ^ pattern X - | IEType (Located name) -- ^ type (:+:) - deriving (Eq,Data) - --- | Located name with possible adornment --- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType', --- 'ApiAnnotation.AnnPattern' -type LIEWrappedName name = Located (IEWrappedName name) --- For details on above see note [Api annotations] in ApiAnnotation - - --- | Located Import or Export -type LIE pass = Located (IE pass) - -- ^ When in a list this may have - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Imported or exported entity. -data IE pass - = IEVar (XIEVar pass) (LIEWrappedName (IdP pass)) - -- ^ Imported or Exported Variable - - | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass)) - -- ^ Imported or exported Thing with Absent list - -- - -- The thing is a Class/Type (can't tell) - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', - -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnVal' - - -- For details on above see note [Api annotations] in ApiAnnotation - -- See Note [Located RdrNames] in HsExpr - | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass)) - -- ^ Imported or exported Thing with All imported or exported - -- - -- The thing is a Class/Type and the All refers to methods/constructors - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnType' - - -- For details on above see note [Api annotations] in ApiAnnotation - -- See Note [Located RdrNames] in HsExpr - - | IEThingWith (XIEThingWith pass) - (LIEWrappedName (IdP pass)) - IEWildcard - [LIEWrappedName (IdP pass)] - [Located (FieldLbl (IdP pass))] - -- ^ Imported or exported Thing With given imported or exported - -- - -- The thing is a Class/Type and the imported or exported things are - -- methods/constructors and record fields; see Note [IEThingWith] - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnComma', - -- 'ApiAnnotation.AnnType' - - -- For details on above see note [Api annotations] in ApiAnnotation - | IEModuleContents (XIEModuleContents pass) (Located ModuleName) - -- ^ Imported or exported module contents - -- - -- (Export Only) - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule' - - -- For details on above see note [Api annotations] in ApiAnnotation - | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading - | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation - | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc - | XIE (XXIE pass) - -type instance XIEVar (GhcPass _) = NoExtField -type instance XIEThingAbs (GhcPass _) = NoExtField -type instance XIEThingAll (GhcPass _) = NoExtField -type instance XIEThingWith (GhcPass _) = NoExtField -type instance XIEModuleContents (GhcPass _) = NoExtField -type instance XIEGroup (GhcPass _) = NoExtField -type instance XIEDoc (GhcPass _) = NoExtField -type instance XIEDocNamed (GhcPass _) = NoExtField -type instance XXIE (GhcPass _) = NoExtCon - --- | Imported or Exported Wildcard -data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) - -{- -Note [IEThingWith] -~~~~~~~~~~~~~~~~~~ - -A definition like - - module M ( T(MkT, x) ) where - data T = MkT { x :: Int } - -gives rise to - - IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) - IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) - -See Note [Representing fields in AvailInfo] in Avail for more details. --} - -ieName :: IE (GhcPass p) -> IdP (GhcPass p) -ieName (IEVar _ (L _ n)) = ieWrappedName n -ieName (IEThingAbs _ (L _ n)) = ieWrappedName n -ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n -ieName (IEThingAll _ (L _ n)) = ieWrappedName n -ieName _ = panic "ieName failed pattern match!" - -ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] -ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n - : map (ieWrappedName . unLoc) ns -ieNames (IEModuleContents {}) = [] -ieNames (IEGroup {}) = [] -ieNames (IEDoc {}) = [] -ieNames (IEDocNamed {}) = [] -ieNames (XIE nec) = noExtCon nec - -ieWrappedName :: IEWrappedName name -> name -ieWrappedName (IEName (L _ n)) = n -ieWrappedName (IEPattern (L _ n)) = n -ieWrappedName (IEType (L _ n)) = n - -lieWrappedName :: LIEWrappedName name -> name -lieWrappedName (L _ n) = ieWrappedName n - -ieLWrappedName :: LIEWrappedName name -> Located name -ieLWrappedName (L l n) = L l (ieWrappedName n) - -replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 -replaceWrappedName (IEName (L l _)) n = IEName (L l n) -replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n) -replaceWrappedName (IEType (L l _)) n = IEType (L l n) - -replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 -replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') - -instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where - ppr (IEVar _ var) = ppr (unLoc var) - ppr (IEThingAbs _ thing) = ppr (unLoc thing) - ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] - ppr (IEThingWith _ thing wc withs flds) - = ppr (unLoc thing) <> parens (fsep (punctuate comma - (ppWiths ++ - map (ppr . flLabel . unLoc) flds))) - where - ppWiths = - case wc of - NoIEWildcard -> - map (ppr . unLoc) withs - IEWildcard pos -> - let (bs, as) = splitAt pos (map (ppr . unLoc) withs) - in bs ++ [text ".."] ++ as - ppr (IEModuleContents _ mod') - = text "module" <+> ppr mod' - ppr (IEGroup _ n _) = text ("") - ppr (IEDoc _ doc) = ppr doc - ppr (IEDocNamed _ string) = text ("") - ppr (XIE x) = ppr x - -instance (HasOccName name) => HasOccName (IEWrappedName name) where - occName w = occName (ieWrappedName w) - -instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where - pprBndr bs w = pprBndr bs (ieWrappedName w) - pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) - pprInfixOcc w = pprInfixOcc (ieWrappedName w) - -instance (OutputableBndr name) => Outputable (IEWrappedName name) where - ppr (IEName n) = pprPrefixOcc (unLoc n) - ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n) - ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n) - -pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc -pprImpExp name = type_pref <+> pprPrefixOcc name - where - occ = occName name - type_pref | isTcOcc occ && isSymOcc occ = text "type" - | otherwise = empty diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs deleted file mode 100644 index 9c0698b7ef..0000000000 --- a/compiler/hsSyn/HsInstances.hs +++ /dev/null @@ -1,420 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module HsInstances where - --- This module defines the Data instances for the hsSyn AST. - --- It happens here to avoid massive constraint types on the AST with concomitant --- slow GHC bootstrap times. - --- UndecidableInstances ? - -import Data.Data hiding ( Fixity ) - -import GhcPrelude -import HsExtension -import HsBinds -import HsDecls -import HsExpr -import HsLit -import HsTypes -import HsPat -import HsImpExp - --- --------------------------------------------------------------------- --- Data derivations from HsSyn ----------------------------------------- - --- --------------------------------------------------------------------- --- Data derivations from HsBinds --------------------------------------- - --- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR) -deriving instance Data (HsLocalBindsLR GhcPs GhcPs) -deriving instance Data (HsLocalBindsLR GhcPs GhcRn) -deriving instance Data (HsLocalBindsLR GhcRn GhcRn) -deriving instance Data (HsLocalBindsLR GhcTc GhcTc) - --- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR) -deriving instance Data (HsValBindsLR GhcPs GhcPs) -deriving instance Data (HsValBindsLR GhcPs GhcRn) -deriving instance Data (HsValBindsLR GhcRn GhcRn) -deriving instance Data (HsValBindsLR GhcTc GhcTc) - --- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) -deriving instance Data (NHsValBindsLR GhcPs) -deriving instance Data (NHsValBindsLR GhcRn) -deriving instance Data (NHsValBindsLR GhcTc) - --- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR) -deriving instance Data (HsBindLR GhcPs GhcPs) -deriving instance Data (HsBindLR GhcPs GhcRn) -deriving instance Data (HsBindLR GhcRn GhcRn) -deriving instance Data (HsBindLR GhcTc GhcTc) - --- deriving instance (DataId p) => Data (ABExport p) -deriving instance Data (ABExport GhcPs) -deriving instance Data (ABExport GhcRn) -deriving instance Data (ABExport GhcTc) - --- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) -deriving instance Data (PatSynBind GhcPs GhcPs) -deriving instance Data (PatSynBind GhcPs GhcRn) -deriving instance Data (PatSynBind GhcRn GhcRn) -deriving instance Data (PatSynBind GhcTc GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsIPBinds p) -deriving instance Data (HsIPBinds GhcPs) -deriving instance Data (HsIPBinds GhcRn) -deriving instance Data (HsIPBinds GhcTc) - --- deriving instance (DataIdLR p p) => Data (IPBind p) -deriving instance Data (IPBind GhcPs) -deriving instance Data (IPBind GhcRn) -deriving instance Data (IPBind GhcTc) - --- deriving instance (DataIdLR p p) => Data (Sig p) -deriving instance Data (Sig GhcPs) -deriving instance Data (Sig GhcRn) -deriving instance Data (Sig GhcTc) - --- deriving instance (DataId p) => Data (FixitySig p) -deriving instance Data (FixitySig GhcPs) -deriving instance Data (FixitySig GhcRn) -deriving instance Data (FixitySig GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsPatSynDir p) -deriving instance Data (HsPatSynDir GhcPs) -deriving instance Data (HsPatSynDir GhcRn) -deriving instance Data (HsPatSynDir GhcTc) - --- --------------------------------------------------------------------- --- Data derivations from HsDecls --------------------------------------- - --- deriving instance (DataIdLR p p) => Data (HsDecl p) -deriving instance Data (HsDecl GhcPs) -deriving instance Data (HsDecl GhcRn) -deriving instance Data (HsDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsGroup p) -deriving instance Data (HsGroup GhcPs) -deriving instance Data (HsGroup GhcRn) -deriving instance Data (HsGroup GhcTc) - --- deriving instance (DataIdLR p p) => Data (SpliceDecl p) -deriving instance Data (SpliceDecl GhcPs) -deriving instance Data (SpliceDecl GhcRn) -deriving instance Data (SpliceDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (TyClDecl p) -deriving instance Data (TyClDecl GhcPs) -deriving instance Data (TyClDecl GhcRn) -deriving instance Data (TyClDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (TyClGroup p) -deriving instance Data (TyClGroup GhcPs) -deriving instance Data (TyClGroup GhcRn) -deriving instance Data (TyClGroup GhcTc) - --- deriving instance (DataIdLR p p) => Data (FamilyResultSig p) -deriving instance Data (FamilyResultSig GhcPs) -deriving instance Data (FamilyResultSig GhcRn) -deriving instance Data (FamilyResultSig GhcTc) - --- deriving instance (DataIdLR p p) => Data (FamilyDecl p) -deriving instance Data (FamilyDecl GhcPs) -deriving instance Data (FamilyDecl GhcRn) -deriving instance Data (FamilyDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (InjectivityAnn p) -deriving instance Data (InjectivityAnn GhcPs) -deriving instance Data (InjectivityAnn GhcRn) -deriving instance Data (InjectivityAnn GhcTc) - --- deriving instance (DataIdLR p p) => Data (FamilyInfo p) -deriving instance Data (FamilyInfo GhcPs) -deriving instance Data (FamilyInfo GhcRn) -deriving instance Data (FamilyInfo GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsDataDefn p) -deriving instance Data (HsDataDefn GhcPs) -deriving instance Data (HsDataDefn GhcRn) -deriving instance Data (HsDataDefn GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsDerivingClause p) -deriving instance Data (HsDerivingClause GhcPs) -deriving instance Data (HsDerivingClause GhcRn) -deriving instance Data (HsDerivingClause GhcTc) - --- deriving instance (DataIdLR p p) => Data (ConDecl p) -deriving instance Data (ConDecl GhcPs) -deriving instance Data (ConDecl GhcRn) -deriving instance Data (ConDecl GhcTc) - --- deriving instance DataIdLR p p => Data (TyFamInstDecl p) -deriving instance Data (TyFamInstDecl GhcPs) -deriving instance Data (TyFamInstDecl GhcRn) -deriving instance Data (TyFamInstDecl GhcTc) - --- deriving instance DataIdLR p p => Data (DataFamInstDecl p) -deriving instance Data (DataFamInstDecl GhcPs) -deriving instance Data (DataFamInstDecl GhcRn) -deriving instance Data (DataFamInstDecl GhcTc) - --- deriving instance (DataIdLR p p,Data rhs)=>Data (FamEqn p rhs) -deriving instance Data rhs => Data (FamEqn GhcPs rhs) -deriving instance Data rhs => Data (FamEqn GhcRn rhs) -deriving instance Data rhs => Data (FamEqn GhcTc rhs) - --- deriving instance (DataIdLR p p) => Data (ClsInstDecl p) -deriving instance Data (ClsInstDecl GhcPs) -deriving instance Data (ClsInstDecl GhcRn) -deriving instance Data (ClsInstDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (InstDecl p) -deriving instance Data (InstDecl GhcPs) -deriving instance Data (InstDecl GhcRn) -deriving instance Data (InstDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (DerivDecl p) -deriving instance Data (DerivDecl GhcPs) -deriving instance Data (DerivDecl GhcRn) -deriving instance Data (DerivDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (DerivStrategy p) -deriving instance Data (DerivStrategy GhcPs) -deriving instance Data (DerivStrategy GhcRn) -deriving instance Data (DerivStrategy GhcTc) - --- deriving instance (DataIdLR p p) => Data (DefaultDecl p) -deriving instance Data (DefaultDecl GhcPs) -deriving instance Data (DefaultDecl GhcRn) -deriving instance Data (DefaultDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (ForeignDecl p) -deriving instance Data (ForeignDecl GhcPs) -deriving instance Data (ForeignDecl GhcRn) -deriving instance Data (ForeignDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (RuleDecls p) -deriving instance Data (RuleDecls GhcPs) -deriving instance Data (RuleDecls GhcRn) -deriving instance Data (RuleDecls GhcTc) - --- deriving instance (DataIdLR p p) => Data (RuleDecl p) -deriving instance Data (RuleDecl GhcPs) -deriving instance Data (RuleDecl GhcRn) -deriving instance Data (RuleDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (RuleBndr p) -deriving instance Data (RuleBndr GhcPs) -deriving instance Data (RuleBndr GhcRn) -deriving instance Data (RuleBndr GhcTc) - --- deriving instance (DataId p) => Data (WarnDecls p) -deriving instance Data (WarnDecls GhcPs) -deriving instance Data (WarnDecls GhcRn) -deriving instance Data (WarnDecls GhcTc) - --- deriving instance (DataId p) => Data (WarnDecl p) -deriving instance Data (WarnDecl GhcPs) -deriving instance Data (WarnDecl GhcRn) -deriving instance Data (WarnDecl GhcTc) - --- deriving instance (DataIdLR p p) => Data (AnnDecl p) -deriving instance Data (AnnDecl GhcPs) -deriving instance Data (AnnDecl GhcRn) -deriving instance Data (AnnDecl GhcTc) - --- deriving instance (DataId p) => Data (RoleAnnotDecl p) -deriving instance Data (RoleAnnotDecl GhcPs) -deriving instance Data (RoleAnnotDecl GhcRn) -deriving instance Data (RoleAnnotDecl GhcTc) - --- --------------------------------------------------------------------- --- Data derivations from HsExpr ---------------------------------------- - --- deriving instance (DataIdLR p p) => Data (SyntaxExpr p) -deriving instance Data (SyntaxExpr GhcPs) -deriving instance Data (SyntaxExpr GhcRn) -deriving instance Data (SyntaxExpr GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsExpr p) -deriving instance Data (HsExpr GhcPs) -deriving instance Data (HsExpr GhcRn) -deriving instance Data (HsExpr GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsTupArg p) -deriving instance Data (HsTupArg GhcPs) -deriving instance Data (HsTupArg GhcRn) -deriving instance Data (HsTupArg GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsCmd p) -deriving instance Data (HsCmd GhcPs) -deriving instance Data (HsCmd GhcRn) -deriving instance Data (HsCmd GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsCmdTop p) -deriving instance Data (HsCmdTop GhcPs) -deriving instance Data (HsCmdTop GhcRn) -deriving instance Data (HsCmdTop GhcTc) - --- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body) -deriving instance (Data body) => Data (MatchGroup GhcPs body) -deriving instance (Data body) => Data (MatchGroup GhcRn body) -deriving instance (Data body) => Data (MatchGroup GhcTc body) - --- deriving instance (DataIdLR p p,Data body) => Data (Match p body) -deriving instance (Data body) => Data (Match GhcPs body) -deriving instance (Data body) => Data (Match GhcRn body) -deriving instance (Data body) => Data (Match GhcTc body) - --- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body) -deriving instance (Data body) => Data (GRHSs GhcPs body) -deriving instance (Data body) => Data (GRHSs GhcRn body) -deriving instance (Data body) => Data (GRHSs GhcTc body) - --- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body) -deriving instance (Data body) => Data (GRHS GhcPs body) -deriving instance (Data body) => Data (GRHS GhcRn body) -deriving instance (Data body) => Data (GRHS GhcTc body) - --- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body) -deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body) -deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body) -deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body) -deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body) - -deriving instance Data RecStmtTc - --- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p) -deriving instance Data (ParStmtBlock GhcPs GhcPs) -deriving instance Data (ParStmtBlock GhcPs GhcRn) -deriving instance Data (ParStmtBlock GhcRn GhcRn) -deriving instance Data (ParStmtBlock GhcTc GhcTc) - --- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) -deriving instance Data (ApplicativeArg GhcPs) -deriving instance Data (ApplicativeArg GhcRn) -deriving instance Data (ApplicativeArg GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsSplice p) -deriving instance Data (HsSplice GhcPs) -deriving instance Data (HsSplice GhcRn) -deriving instance Data (HsSplice GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsSplicedThing p) -deriving instance Data (HsSplicedThing GhcPs) -deriving instance Data (HsSplicedThing GhcRn) -deriving instance Data (HsSplicedThing GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsBracket p) -deriving instance Data (HsBracket GhcPs) -deriving instance Data (HsBracket GhcRn) -deriving instance Data (HsBracket GhcTc) - --- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p) -deriving instance Data (ArithSeqInfo GhcPs) -deriving instance Data (ArithSeqInfo GhcRn) -deriving instance Data (ArithSeqInfo GhcTc) - -deriving instance Data RecordConTc -deriving instance Data CmdTopTc -deriving instance Data PendingRnSplice -deriving instance Data PendingTcSplice - --- --------------------------------------------------------------------- --- Data derivations from HsLit ---------------------------------------- - --- deriving instance (DataId p) => Data (HsLit p) -deriving instance Data (HsLit GhcPs) -deriving instance Data (HsLit GhcRn) -deriving instance Data (HsLit GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsOverLit p) -deriving instance Data (HsOverLit GhcPs) -deriving instance Data (HsOverLit GhcRn) -deriving instance Data (HsOverLit GhcTc) - --- --------------------------------------------------------------------- --- Data derivations from HsPat ----------------------------------------- - --- deriving instance (DataIdLR p p) => Data (Pat p) -deriving instance Data (Pat GhcPs) -deriving instance Data (Pat GhcRn) -deriving instance Data (Pat GhcTc) - -deriving instance Data ListPatTc - --- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) -deriving instance (Data body) => Data (HsRecFields GhcPs body) -deriving instance (Data body) => Data (HsRecFields GhcRn body) -deriving instance (Data body) => Data (HsRecFields GhcTc body) - --- --------------------------------------------------------------------- --- Data derivations from HsTypes --------------------------------------- - --- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) -deriving instance Data (LHsQTyVars GhcPs) -deriving instance Data (LHsQTyVars GhcRn) -deriving instance Data (LHsQTyVars GhcTc) - --- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing) -deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing) -deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing) -deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing) - --- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) -deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) -deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) -deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) - --- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) -deriving instance Data (HsTyVarBndr GhcPs) -deriving instance Data (HsTyVarBndr GhcRn) -deriving instance Data (HsTyVarBndr GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsType p) -deriving instance Data (HsType GhcPs) -deriving instance Data (HsType GhcRn) -deriving instance Data (HsType GhcTc) - -deriving instance Data (LHsTypeArg GhcPs) -deriving instance Data (LHsTypeArg GhcRn) -deriving instance Data (LHsTypeArg GhcTc) - --- deriving instance (DataIdLR p p) => Data (ConDeclField p) -deriving instance Data (ConDeclField GhcPs) -deriving instance Data (ConDeclField GhcRn) -deriving instance Data (ConDeclField GhcTc) - --- deriving instance (DataId p) => Data (FieldOcc p) -deriving instance Data (FieldOcc GhcPs) -deriving instance Data (FieldOcc GhcRn) -deriving instance Data (FieldOcc GhcTc) - --- deriving instance DataId p => Data (AmbiguousFieldOcc p) -deriving instance Data (AmbiguousFieldOcc GhcPs) -deriving instance Data (AmbiguousFieldOcc GhcRn) -deriving instance Data (AmbiguousFieldOcc GhcTc) - - --- deriving instance (DataId name) => Data (ImportDecl name) -deriving instance Data (ImportDecl GhcPs) -deriving instance Data (ImportDecl GhcRn) -deriving instance Data (ImportDecl GhcTc) - --- deriving instance (DataId name) => Data (IE name) -deriving instance Data (IE GhcPs) -deriving instance Data (IE GhcRn) -deriving instance Data (IE GhcTc) - --- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) -deriving instance Eq (IE GhcPs) -deriving instance Eq (IE GhcRn) -deriving instance Eq (IE GhcTc) - --- --------------------------------------------------------------------- diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs deleted file mode 100644 index 074c7295af..0000000000 --- a/compiler/hsSyn/HsLit.hs +++ /dev/null @@ -1,314 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[HsLit]{Abstract syntax: source-language literals} --} - -{-# LANGUAGE CPP, DeriveDataTypeable #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} - -module HsLit where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) -import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, - negateFractionalLit,SourceText(..),pprWithSourceText ) -import Type -import Outputable -import FastString -import HsExtension - -import Data.ByteString (ByteString) -import Data.Data hiding ( Fixity ) - -{- -************************************************************************ -* * -\subsection[HsLit]{Literals} -* * -************************************************************************ --} - --- Note [Literal source text] in BasicTypes for SourceText fields in --- the following --- Note [Trees that grow] in HsExtension for the Xxxxx fields in the following --- | Haskell Literal -data HsLit x - = HsChar (XHsChar x) {- SourceText -} Char - -- ^ Character - | HsCharPrim (XHsCharPrim x) {- SourceText -} Char - -- ^ Unboxed character - | HsString (XHsString x) {- SourceText -} FastString - -- ^ String - | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString - -- ^ Packed bytes - | HsInt (XHsInt x) IntegralLit - -- ^ Genuinely an Int; arises from - -- @TcGenDeriv@, and from TRANSLATION - | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer - -- ^ literal @Int#@ - | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer - -- ^ literal @Word#@ - | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer - -- ^ literal @Int64#@ - | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer - -- ^ literal @Word64#@ - | HsInteger (XHsInteger x) {- SourceText -} Integer Type - -- ^ Genuinely an integer; arises only - -- from TRANSLATION (overloaded - -- literals are done with HsOverLit) - | HsRat (XHsRat x) FractionalLit Type - -- ^ Genuinely a rational; arises only from - -- TRANSLATION (overloaded literals are - -- done with HsOverLit) - | HsFloatPrim (XHsFloatPrim x) FractionalLit - -- ^ Unboxed Float - | HsDoublePrim (XHsDoublePrim x) FractionalLit - -- ^ Unboxed Double - - | XLit (XXLit x) - -type instance XHsChar (GhcPass _) = SourceText -type instance XHsCharPrim (GhcPass _) = SourceText -type instance XHsString (GhcPass _) = SourceText -type instance XHsStringPrim (GhcPass _) = SourceText -type instance XHsInt (GhcPass _) = NoExtField -type instance XHsIntPrim (GhcPass _) = SourceText -type instance XHsWordPrim (GhcPass _) = SourceText -type instance XHsInt64Prim (GhcPass _) = SourceText -type instance XHsWord64Prim (GhcPass _) = SourceText -type instance XHsInteger (GhcPass _) = SourceText -type instance XHsRat (GhcPass _) = NoExtField -type instance XHsFloatPrim (GhcPass _) = NoExtField -type instance XHsDoublePrim (GhcPass _) = NoExtField -type instance XXLit (GhcPass _) = NoExtCon - -instance Eq (HsLit x) where - (HsChar _ x1) == (HsChar _ x2) = x1==x2 - (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 - (HsString _ x1) == (HsString _ x2) = x1==x2 - (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 - (HsInt _ x1) == (HsInt _ x2) = x1==x2 - (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 - (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 - (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 - (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 - (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2 - (HsRat _ x1 _) == (HsRat _ x2 _) = x1==x2 - (HsFloatPrim _ x1) == (HsFloatPrim _ x2) = x1==x2 - (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2 - _ == _ = False - --- | Haskell Overloaded Literal -data HsOverLit p - = OverLit { - ol_ext :: (XOverLit p), - ol_val :: OverLitVal, - ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] - - | XOverLit - (XXOverLit p) - -data OverLitTc - = OverLitTc { - ol_rebindable :: Bool, -- Note [ol_rebindable] - ol_type :: Type } - deriving Data - -type instance XOverLit GhcPs = NoExtField -type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] -type instance XOverLit GhcTc = OverLitTc - -type instance XXOverLit (GhcPass _) = NoExtCon - --- Note [Literal source text] in BasicTypes for SourceText fields in --- the following --- | Overloaded Literal Value -data OverLitVal - = HsIntegral !IntegralLit -- ^ Integer-looking literals; - | HsFractional !FractionalLit -- ^ Frac-looking literals - | HsIsString !SourceText !FastString -- ^ String-looking literals - deriving Data - -negateOverLitVal :: OverLitVal -> OverLitVal -negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) -negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) -negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" - -overLitType :: HsOverLit GhcTc -> Type -overLitType (OverLit (OverLitTc _ ty) _ _) = ty -overLitType (XOverLit nec) = noExtCon nec - --- | Convert a literal from one index type to another, updating the annotations --- according to the relevant 'Convertable' instance -convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b -convertLit (HsChar a x) = (HsChar (convert a) x) -convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) -convertLit (HsString a x) = (HsString (convert a) x) -convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x) -convertLit (HsInt a x) = (HsInt (convert a) x) -convertLit (HsIntPrim a x) = (HsIntPrim (convert a) x) -convertLit (HsWordPrim a x) = (HsWordPrim (convert a) x) -convertLit (HsInt64Prim a x) = (HsInt64Prim (convert a) x) -convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x) -convertLit (HsInteger a x b) = (HsInteger (convert a) x b) -convertLit (HsRat a x b) = (HsRat (convert a) x b) -convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) -convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) -convertLit (XLit a) = (XLit (convert a)) - -{- -Note [ol_rebindable] -~~~~~~~~~~~~~~~~~~~~ -The ol_rebindable field is True if this literal is actually -using rebindable syntax. Specifically: - - False iff ol_witness is the standard one - True iff ol_witness is non-standard - -Equivalently it's True if - a) RebindableSyntax is on - b) the witness for fromInteger/fromRational/fromString - that happens to be in scope isn't the standard one - -Note [Overloaded literal witnesses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -*Before* type checking, the HsExpr in an HsOverLit is the -name of the coercion function, 'fromInteger' or 'fromRational'. -*After* type checking, it is a witness for the literal, such as - (fromInteger 3) or lit_78 -This witness should replace the literal. - -This dual role is unusual, because we're replacing 'fromInteger' with -a call to fromInteger. Reason: it allows commoning up of the fromInteger -calls, which wouldn't be possible if the desugarer made the application. - -The PostTcType in each branch records the type the overload literal is -found to have. --} - --- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module MatchLit) -instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where - (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 - (XOverLit val1) == (XOverLit val2) = val1 == val2 - _ == _ = panic "Eq HsOverLit" - -instance Eq OverLitVal where - (HsIntegral i1) == (HsIntegral i2) = i1 == i2 - (HsFractional f1) == (HsFractional f2) = f1 == f2 - (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 - _ == _ = False - -instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where - compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2 - compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 - compare _ _ = panic "Ord HsOverLit" - -instance Ord OverLitVal where - compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 - compare (HsIntegral _) (HsFractional _) = LT - compare (HsIntegral _) (HsIsString _ _) = LT - compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 - compare (HsFractional _) (HsIntegral _) = GT - compare (HsFractional _) (HsIsString _ _) = LT - compare (HsIsString _ s1) (HsIsString _ s2) = s1 `compare` s2 - compare (HsIsString _ _) (HsIntegral _) = GT - compare (HsIsString _ _) (HsFractional _) = GT - --- Instance specific to GhcPs, need the SourceText -instance p ~ GhcPass pass => Outputable (HsLit p) where - ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) - ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) - ppr (HsString st s) = pprWithSourceText st (pprHsString s) - ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) - ppr (HsInt _ i) - = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsInteger st i _) = pprWithSourceText st (integer i) - ppr (HsRat _ f _) = ppr f - ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix - ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix - ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) - ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) - ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) - ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) - ppr (XLit x) = ppr x - -pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc -pp_st_suffix NoSourceText _ doc = doc -pp_st_suffix (SourceText st) suffix _ = text st <> suffix - --- in debug mode, print the expression that it's resolved to, too -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsOverLit p) where - ppr (OverLit {ol_val=val, ol_witness=witness}) - = ppr val <+> (whenPprDebug (parens (pprExpr witness))) - ppr (XOverLit x) = ppr x - -instance Outputable OverLitVal where - ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsFractional f) = ppr f - ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) - --- | pmPprHsLit pretty prints literals and is used when pretty printing pattern --- match warnings. All are printed the same (i.e., without hashes if they are --- primitive and not wrapped in constructors if they are boxed). This happens --- mainly for too reasons: --- * We do not want to expose their internal representation --- * The warnings become too messy -pmPprHsLit :: HsLit (GhcPass x) -> SDoc -pmPprHsLit (HsChar _ c) = pprHsChar c -pmPprHsLit (HsCharPrim _ c) = pprHsChar c -pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) -pmPprHsLit (HsStringPrim _ s) = pprHsBytes s -pmPprHsLit (HsInt _ i) = integer (il_value i) -pmPprHsLit (HsIntPrim _ i) = integer i -pmPprHsLit (HsWordPrim _ w) = integer w -pmPprHsLit (HsInt64Prim _ i) = integer i -pmPprHsLit (HsWord64Prim _ w) = integer w -pmPprHsLit (HsInteger _ i _) = integer i -pmPprHsLit (HsRat _ f _) = ppr f -pmPprHsLit (HsFloatPrim _ f) = ppr f -pmPprHsLit (HsDoublePrim _ d) = ppr d -pmPprHsLit (XLit x) = ppr x - --- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs --- to be parenthesized under precedence @p@. -hsLitNeedsParens :: PprPrec -> HsLit x -> Bool -hsLitNeedsParens p = go - where - go (HsChar {}) = False - go (HsCharPrim {}) = False - go (HsString {}) = False - go (HsStringPrim {}) = False - go (HsInt _ x) = p > topPrec && il_neg x - go (HsIntPrim _ x) = p > topPrec && x < 0 - go (HsWordPrim {}) = False - go (HsInt64Prim _ x) = p > topPrec && x < 0 - go (HsWord64Prim {}) = False - go (HsInteger _ x _) = p > topPrec && x < 0 - go (HsRat _ x _) = p > topPrec && fl_neg x - go (HsFloatPrim _ x) = p > topPrec && fl_neg x - go (HsDoublePrim _ x) = p > topPrec && fl_neg x - go (XLit _) = False - --- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal --- @ol@ needs to be parenthesized under precedence @p@. -hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool -hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv - where - go :: OverLitVal -> Bool - go (HsIntegral x) = p > topPrec && il_neg x - go (HsFractional x) = p > topPrec && fl_neg x - go (HsIsString {}) = False -hsOverLitNeedsParens _ (XOverLit { }) = False diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs deleted file mode 100644 index 06270e8a89..0000000000 --- a/compiler/hsSyn/HsPat.hs +++ /dev/null @@ -1,846 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[PatSyntax]{Abstract Haskell syntax---patterns} --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleInstances #-} - -module HsPat ( - Pat(..), InPat, OutPat, LPat, - ListPatTc(..), - - HsConPatDetails, hsConPatArgs, - HsRecFields(..), HsRecField'(..), LHsRecField', - HsRecField, LHsRecField, - HsRecUpdField, LHsRecUpdField, - hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, - hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, - - mkPrefixConPat, mkCharLitPat, mkNilPat, - - looksLazyPatBind, - isBangedLPat, - patNeedsParens, parenthesizePat, - isIrrefutableHsPat, - - collectEvVarsPat, collectEvVarsPats, - - pprParendLPat, pprConArgs - ) where - -import GhcPrelude - -import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice) - --- friends: -import HsBinds -import HsLit -import HsExtension -import HsTypes -import TcEvidence -import BasicTypes --- others: -import PprCore ( {- instance OutputableBndr TyVar -} ) -import TysWiredIn -import Var -import RdrName ( RdrName ) -import ConLike -import DataCon -import TyCon -import Outputable -import Type -import SrcLoc -import Bag -- collect ev vars from pats -import DynFlags( gopt, GeneralFlag(..) ) -import Maybes --- libraries: -import Data.Data hiding (TyCon,Fixity) - -type InPat p = LPat p -- No 'Out' constructors -type OutPat p = LPat p -- No 'In' constructors - -type LPat p = Pat p - --- | Pattern --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' - --- For details on above see note [Api annotations] in ApiAnnotation -data Pat p - = ------------ Simple patterns --------------- - WildPat (XWildPat p) -- ^ Wildcard Pattern - -- The sole reason for a type on a WildPat is to - -- support hsPatType :: Pat Id -> Type - - -- AZ:TODO above comment needs to be updated - | VarPat (XVarPat p) - (Located (IdP p)) -- ^ Variable Pattern - - -- See Note [Located RdrNames] in HsExpr - | LazyPat (XLazyPat p) - (LPat p) -- ^ Lazy Pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | AsPat (XAsPat p) - (Located (IdP p)) (LPat p) -- ^ As pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | ParPat (XParPat p) - (LPat p) -- ^ Parenthesised pattern - -- See Note [Parens in HsSyn] in HsExpr - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | BangPat (XBangPat p) - (LPat p) -- ^ Bang pattern - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' - - -- For details on above see note [Api annotations] in ApiAnnotation - - ------------ Lists, tuples, arrays --------------- - | ListPat (XListPat p) - [LPat p] - -- For OverloadedLists a Just (ty,fn) gives - -- overall type of the pattern, and the toList --- function to convert the scrutinee to a list value - - -- ^ Syntactic List - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | TuplePat (XTuplePat p) - -- after typechecking, holds the types of the tuple components - [LPat p] -- Tuple sub-patterns - Boxity -- UnitPat is TuplePat [] - -- You might think that the post typechecking Type was redundant, - -- because we can get the pattern type by getting the types of the - -- sub-patterns. - -- But it's essential - -- data T a where - -- T1 :: Int -> T Int - -- f :: (T a, a) -> Int - -- f (T1 x, z) = z - -- When desugaring, we must generate - -- f = /\a. \v::a. case v of (t::T a, w::a) -> - -- case t of (T1 (x::Int)) -> - -- Note the (w::a), NOT (w::Int), because we have not yet - -- refined 'a' to Int. So we must know that the second component - -- of the tuple is of type 'a' not Int. See selectMatchVar - -- (June 14: I'm not sure this comment is right; the sub-patterns - -- will be wrapped in CoPats, no?) - -- ^ Tuple sub-patterns - -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, - -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ - - | SumPat (XSumPat p) -- PlaceHolder before typechecker, filled in - -- afterwards with the types of the - -- alternative - (LPat p) -- Sum sub-pattern - ConTag -- Alternative (one-based) - Arity -- Arity (INVARIANT: ≥ 2) - -- ^ Anonymous sum pattern - -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnClose' @'#)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - ------------ Constructor patterns --------------- - | ConPatIn (Located (IdP p)) - (HsConPatDetails p) - -- ^ Constructor Pattern In - - | ConPatOut { - pat_con :: Located ConLike, - pat_arg_tys :: [Type], -- The universal arg types, 1-1 with the universal - -- tyvars of the constructor/pattern synonym - -- Use (conLikeResTy pat_con pat_arg_tys) to get - -- the type of the pattern - - pat_tvs :: [TyVar], -- Existentially bound type variables - -- in correctly-scoped order e.g. [k:*, x:k] - pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* - -- One reason for putting coercion variable here, I think, - -- is to ensure their kinds are zonked - - pat_binds :: TcEvBinds, -- Bindings involving those dictionaries - pat_args :: HsConPatDetails p, - pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher - -- Only relevant for pattern-synonyms; - -- ignored for data cons - } - -- ^ Constructor Pattern Out - - ------------ View patterns --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' - - -- For details on above see note [Api annotations] in ApiAnnotation - | ViewPat (XViewPat p) -- The overall type of the pattern - -- (= the argument type of the view function) - -- for hsPatType. - (LHsExpr p) - (LPat p) - -- ^ View Pattern - - ------------ Pattern splices --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@ - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | SplicePat (XSplicePat p) - (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) - - ------------ Literal and n+k patterns --------------- - | LitPat (XLitPat p) - (HsLit p) -- ^ Literal Pattern - -- Used for *non-overloaded* literal patterns: - -- Int#, Char#, Int, Char, String, etc. - - | NPat -- Natural Pattern - -- Used for all overloaded literals, - -- including overloaded strings with -XOverloadedStrings - (XNPat p) -- Overall type of pattern. Might be - -- different than the literal's type - -- if (==) or negate changes the type - (Located (HsOverLit p)) -- ALWAYS positive - (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for - -- negative patterns, Nothing - -- otherwise - (SyntaxExpr p) -- Equality checker, of type t->t->Bool - - -- ^ Natural Pattern - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - | NPlusKPat (XNPlusKPat p) -- Type of overall pattern - (Located (IdP p)) -- n+k pattern - (Located (HsOverLit p)) -- It'll always be an HsIntegral - (HsOverLit p) -- See Note [NPlusK patterns] in TcPat - -- NB: This could be (PostTc ...), but that induced a - -- a new hs-boot file. Not worth it. - - (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool - (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) - -- ^ n+k pattern - - ------------ Pattern type signatures --------------- - -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | SigPat (XSigPat p) -- After typechecker: Type - (LPat p) -- Pattern with a type signature - (LHsSigWcType (NoGhcTc p)) -- Signature can bind both - -- kind and type vars - - -- ^ Pattern with a type signature - - ------------ Pattern coercions (translation only) --------------- - | CoPat (XCoPat p) - HsWrapper -- Coercion Pattern - -- If co :: t1 ~ t2, p :: t2, - -- then (CoPat co p) :: t1 - (Pat p) -- Why not LPat? Ans: existing locn will do - Type -- Type of whole pattern, t1 - -- During desugaring a (CoPat co pat) turns into a cast with 'co' on - -- the scrutinee, followed by a match on 'pat' - -- ^ Coercion Pattern - - -- | Trees that Grow extension point for new constructors - | XPat - (XXPat p) - --- --------------------------------------------------------------------- - -data ListPatTc - = ListPatTc - Type -- The type of the elements - (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax - -type instance XWildPat GhcPs = NoExtField -type instance XWildPat GhcRn = NoExtField -type instance XWildPat GhcTc = Type - -type instance XVarPat (GhcPass _) = NoExtField -type instance XLazyPat (GhcPass _) = NoExtField -type instance XAsPat (GhcPass _) = NoExtField -type instance XParPat (GhcPass _) = NoExtField -type instance XBangPat (GhcPass _) = NoExtField - --- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap --- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for --- `SyntaxExpr` -type instance XListPat GhcPs = NoExtField -type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) -type instance XListPat GhcTc = ListPatTc - -type instance XTuplePat GhcPs = NoExtField -type instance XTuplePat GhcRn = NoExtField -type instance XTuplePat GhcTc = [Type] - -type instance XSumPat GhcPs = NoExtField -type instance XSumPat GhcRn = NoExtField -type instance XSumPat GhcTc = [Type] - -type instance XViewPat GhcPs = NoExtField -type instance XViewPat GhcRn = NoExtField -type instance XViewPat GhcTc = Type - -type instance XSplicePat (GhcPass _) = NoExtField -type instance XLitPat (GhcPass _) = NoExtField - -type instance XNPat GhcPs = NoExtField -type instance XNPat GhcRn = NoExtField -type instance XNPat GhcTc = Type - -type instance XNPlusKPat GhcPs = NoExtField -type instance XNPlusKPat GhcRn = NoExtField -type instance XNPlusKPat GhcTc = Type - -type instance XSigPat GhcPs = NoExtField -type instance XSigPat GhcRn = NoExtField -type instance XSigPat GhcTc = Type - -type instance XCoPat (GhcPass _) = NoExtField -type instance XXPat (GhcPass p) = Located (Pat (GhcPass p)) - - -{- -************************************************************************ -* * -* HasSrcSpan Instance -* * -************************************************************************ --} - -type instance SrcSpanLess (LPat (GhcPass p)) = Pat (GhcPass p) -instance HasSrcSpan (LPat (GhcPass p)) where - -- NB: The following chooses the behaviour of the outer location - -- wrapper replacing the inner ones. - composeSrcSpan (L sp p) = if sp == noSrcSpan - then p - else XPat (L sp (stripSrcSpanPat p)) - - -- NB: The following only returns the top-level location, if any. - decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) - decomposeSrcSpan p = L noSrcSpan p - -stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p) -stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p -stripSrcSpanPat p = p - - - --- --------------------------------------------------------------------- - - --- | Haskell Constructor Pattern Details -type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) - -hsConPatArgs :: HsConPatDetails p -> [LPat p] -hsConPatArgs (PrefixCon ps) = ps -hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) -hsConPatArgs (InfixCon p1 p2) = [p1,p2] - --- | Haskell Record Fields --- --- HsRecFields is used only for patterns and expressions (not data type --- declarations) -data HsRecFields p arg -- A bunch of record fields - -- { x = 3, y = True } - -- Used for both expressions and patterns - = HsRecFields { rec_flds :: [LHsRecField p arg], - rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] - deriving (Functor, Foldable, Traversable) - - --- Note [DotDot fields] --- ~~~~~~~~~~~~~~~~~~~~ --- The rec_dotdot field means this: --- Nothing => the normal case --- Just n => the group uses ".." notation, --- --- In the latter case: --- --- *before* renamer: rec_flds are exactly the n user-written fields --- --- *after* renamer: rec_flds includes *all* fields, with --- the first 'n' being the user-written ones --- and the remainder being 'filled in' implicitly - --- | Located Haskell Record Field -type LHsRecField' p arg = Located (HsRecField' p arg) - --- | Located Haskell Record Field -type LHsRecField p arg = Located (HsRecField p arg) - --- | Located Haskell Record Update Field -type LHsRecUpdField p = Located (HsRecUpdField p) - --- | Haskell Record Field -type HsRecField p arg = HsRecField' (FieldOcc p) arg - --- | Haskell Record Update Field -type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p) - --- | Haskell Record Field --- --- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', --- --- For details on above see note [Api annotations] in ApiAnnotation -data HsRecField' id arg = HsRecField { - hsRecFieldLbl :: Located id, - hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning - hsRecPun :: Bool -- ^ Note [Punning] - } deriving (Data, Functor, Foldable, Traversable) - - --- Note [Punning] --- ~~~~~~~~~~~~~~ --- If you write T { x, y = v+1 }, the HsRecFields will be --- HsRecField x x True ... --- HsRecField y (v+1) False ... --- That is, for "punned" field x is expanded (in the renamer) --- to x=x; but with a punning flag so we can detect it later --- (e.g. when pretty printing) --- --- If the original field was qualified, we un-qualify it, thus --- T { A.x } means T { A.x = x } - - --- Note [HsRecField and HsRecUpdField] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- A HsRecField (used for record construction and pattern matching) --- contains an unambiguous occurrence of a field (i.e. a FieldOcc). --- We can't just store the Name, because thanks to --- DuplicateRecordFields this may not correspond to the label the user --- wrote. --- --- A HsRecUpdField (used for record update) contains a potentially --- ambiguous occurrence of a field (an AmbiguousFieldOcc). The --- renamer will fill in the selector function if it can, but if the --- selector is ambiguous the renamer will defer to the typechecker. --- After the typechecker, a unique selector will have been determined. --- --- The renamer produces an Unambiguous result if it can, rather than --- just doing the lookup in the typechecker, so that completely --- unambiguous updates can be represented by 'DsMeta.repUpdFields'. --- --- For example, suppose we have: --- --- data S = MkS { x :: Int } --- data T = MkT { x :: Int } --- --- f z = (z { x = 3 }) :: S --- --- The parsed HsRecUpdField corresponding to the record update will have: --- --- hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName --- --- After the renamer, this will become: --- --- hsRecFieldLbl = Ambiguous "x" noExtField :: AmbiguousFieldOcc Name --- --- (note that the Unambiguous constructor is not type-correct here). --- The typechecker will determine the particular selector: --- --- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id --- --- See also Note [Disambiguating record fields] in TcExpr. - -hsRecFields :: HsRecFields p arg -> [XCFieldOcc p] -hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) - --- Probably won't typecheck at once, things have changed :/ -hsRecFieldsArgs :: HsRecFields p arg -> [arg] -hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) - -hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass) -hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl - -hsRecFieldId :: HsRecField GhcTc arg -> Located Id -hsRecFieldId = hsRecFieldSel - -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName -hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl - -hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id -hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc - -hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc -hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl - - -{- -************************************************************************ -* * -* Printing patterns -* * -************************************************************************ --} - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where - ppr = pprPat - -pprPatBndr :: OutputableBndr name => name -> SDoc -pprPatBndr var -- Print with type info if -dppr-debug is on - = getPprStyle $ \ sty -> - if debugStyle sty then - parens (pprBndr LambdaBind var) -- Could pass the site to pprPat - -- but is it worth it? - else - pprPrefixOcc var - -pprParendLPat :: (OutputableBndrId (GhcPass p)) - => PprPrec -> LPat (GhcPass p) -> SDoc -pprParendLPat p = pprParendPat p . unLoc - -pprParendPat :: (OutputableBndrId (GhcPass p)) - => PprPrec -> Pat (GhcPass p) -> SDoc -pprParendPat p pat = sdocWithDynFlags $ \ dflags -> - if need_parens dflags pat - then parens (pprPat pat) - else pprPat pat - where - need_parens dflags pat - | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags - | otherwise = patNeedsParens p pat - -- For a CoPat we need parens if we are going to show it, which - -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) - -- But otherwise the CoPat is discarded, so it - -- is the pattern inside that matters. Sigh. - -pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc -pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) -pprPat (WildPat _) = char '_' -pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat -pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat -pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', - pprParendLPat appPrec pat] -pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] -pprPat (ParPat _ pat) = parens (ppr pat) -pprPat (LitPat _ s) = ppr s -pprPat (NPat _ l Nothing _) = ppr l -pprPat (NPat _ l (Just _) _) = char '-' <> ppr l -pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k] -pprPat (SplicePat _ splice) = pprSplice splice -pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens - -> if parens - then pprParendPat appPrec pat - else pprPat pat -pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty -pprPat (ListPat _ pats) = brackets (interpp'SP pats) -pprPat (TuplePat _ pats bx) = tupleParens (boxityTupleSort bx) - (pprWithCommas ppr pats) -pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) -pprPat (ConPatIn con details) = pprUserCon (unLoc con) details -pprPat (ConPatOut { pat_con = con - , pat_tvs = tvs - , pat_dicts = dicts - , pat_binds = binds - , pat_args = details }) - = sdocWithDynFlags $ \dflags -> - -- Tiresome; in TcBinds.tcRhs we print out a - -- typechecked Pat in an error message, - -- and we want to make sure it prints nicely - if gopt Opt_PrintTypecheckerElaboration dflags then - ppr con - <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) - , ppr binds]) - <+> pprConArgs details - else pprUserCon (unLoc con) details -pprPat (XPat x) = ppr x - - -pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p)) - => con -> HsConPatDetails (GhcPass p) -> SDoc -pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 -pprUserCon c details = pprPrefixOcc c <+> pprConArgs details - -pprConArgs :: (OutputableBndrId (GhcPass p)) - => HsConPatDetails (GhcPass p) -> SDoc -pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats) -pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 - , pprParendLPat appPrec p2 ] -pprConArgs (RecCon rpats) = ppr rpats - -instance (Outputable arg) - => Outputable (HsRecFields p arg) where - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) - = braces (fsep (punctuate comma (map ppr flds))) - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) - = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) - where - dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) - -instance (Outputable p, Outputable arg) - => Outputable (HsRecField' p arg) where - ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, - hsRecPun = pun }) - = ppr f <+> (ppUnless pun $ equals <+> ppr arg) - - -{- -************************************************************************ -* * -* Building patterns -* * -************************************************************************ --} - -mkPrefixConPat :: DataCon -> - [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p) --- Make a vanilla Prefix constructor pattern -mkPrefixConPat dc pats tys - = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc) - , pat_tvs = [] - , pat_dicts = [] - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon pats - , pat_arg_tys = tys - , pat_wrap = idHsWrapper } - -mkNilPat :: Type -> OutPat (GhcPass p) -mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] - -mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) -mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat noExtField (HsCharPrim src c)] [] - -{- -************************************************************************ -* * -* Predicates for checking things about pattern-lists in EquationInfo * -* * -************************************************************************ - -\subsection[Pat-list-predicates]{Look for interesting things in patterns} - -Unlike in the Wadler chapter, where patterns are either ``variables'' -or ``constructors,'' here we distinguish between: -\begin{description} -\item[unfailable:] -Patterns that cannot fail to match: variables, wildcards, and lazy -patterns. - -These are the irrefutable patterns; the two other categories -are refutable patterns. - -\item[constructor:] -A non-literal constructor pattern (see next category). - -\item[literal patterns:] -At least the numeric ones may be overloaded. -\end{description} - -A pattern is in {\em exactly one} of the above three categories; `as' -patterns are treated specially, of course. - -The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. --} - -isBangedLPat :: LPat (GhcPass p) -> Bool -isBangedLPat = isBangedPat . unLoc - -isBangedPat :: Pat (GhcPass p) -> Bool -isBangedPat (ParPat _ p) = isBangedLPat p -isBangedPat (BangPat {}) = True -isBangedPat _ = False - -looksLazyPatBind :: HsBind (GhcPass p) -> Bool --- Returns True of anything *except* --- a StrictHsBind (as above) or --- a VarPat --- In particular, returns True of a pattern binding with a compound pattern, like (I# x) --- Looks through AbsBinds -looksLazyPatBind (PatBind { pat_lhs = p }) - = looksLazyLPat p -looksLazyPatBind (AbsBinds { abs_binds = binds }) - = anyBag (looksLazyPatBind . unLoc) binds -looksLazyPatBind _ - = False - -looksLazyLPat :: LPat (GhcPass p) -> Bool -looksLazyLPat = looksLazyPat . unLoc - -looksLazyPat :: Pat (GhcPass p) -> Bool -looksLazyPat (ParPat _ p) = looksLazyLPat p -looksLazyPat (AsPat _ _ p) = looksLazyLPat p -looksLazyPat (BangPat {}) = False -looksLazyPat (VarPat {}) = False -looksLazyPat (WildPat {}) = False -looksLazyPat _ = True - -isIrrefutableHsPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> Bool --- (isIrrefutableHsPat p) is true if matching against p cannot fail, --- in the sense of falling through to the next pattern. --- (NB: this is not quite the same as the (silly) defn --- in 3.17.2 of the Haskell 98 report.) --- --- WARNING: isIrrefutableHsPat returns False if it's in doubt. --- Specifically on a ConPatIn, which is what it sees for a --- (LPat Name) in the renamer, it doesn't know the size of the --- constructor family, so it returns False. Result: only --- tuple patterns are considered irrefuable at the renamer stage. --- --- But if it returns True, the pattern is definitely irrefutable -isIrrefutableHsPat - = goL - where - goL = go . unLoc - - go (WildPat {}) = True - go (VarPat {}) = True - go (LazyPat {}) = True - go (BangPat _ pat) = goL pat - go (CoPat _ _ pat _) = go pat - go (ParPat _ pat) = goL pat - go (AsPat _ _ pat) = goL pat - go (ViewPat _ _ pat) = goL pat - go (SigPat _ pat _) = goL pat - go (TuplePat _ pats _) = all goL pats - go (SumPat {}) = False - -- See Note [Unboxed sum patterns aren't irrefutable] - go (ListPat {}) = False - - go (ConPatIn {}) = False -- Conservative - go (ConPatOut - { pat_con = (dL->L _ (RealDataCon con)) - , pat_args = details }) - = - isJust (tyConSingleDataCon_maybe (dataConTyCon con)) - -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because - -- the latter is false of existentials. See #4439 - && all goL (hsConPatArgs details) - go (ConPatOut - { pat_con = (dL->L _ (PatSynCon _pat)) }) - = False -- Conservative - go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884 - go (LitPat {}) = False - go (NPat {}) = False - go (NPlusKPat {}) = False - - -- We conservatively assume that no TH splices are irrefutable - -- since we cannot know until the splice is evaluated. - go (SplicePat {}) = False - - go (XPat {}) = False - -{- Note [Unboxed sum patterns aren't irrefutable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as -patterns. A simple example that demonstrates this is from #14228: - - pattern Just' x = (# x | #) - pattern Nothing' = (# | () #) - - foo x = case x of - Nothing' -> putStrLn "nothing" - Just' -> putStrLn "just" - -In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable, -as does not match an unboxed sum value of the same arity—namely, (# | y #) -(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the -minimum unboxed sum arity is 2. - -Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' -case in foo to be unreachable, as GHC would mistakenly believe that Nothing' -is the only thing that could possibly be matched! --} - --- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs --- parentheses under precedence @p@. -patNeedsParens :: PprPrec -> Pat p -> Bool -patNeedsParens p = go - where - go (NPlusKPat {}) = p > opPrec - go (SplicePat {}) = False - go (ConPatIn _ ds) = conPatNeedsParens p ds - go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp) - go (SigPat {}) = p >= sigPrec - go (ViewPat {}) = True - go (CoPat _ _ p _) = go p - go (WildPat {}) = False - go (VarPat {}) = False - go (LazyPat {}) = False - go (BangPat {}) = False - go (ParPat {}) = False - go (AsPat {}) = False - go (TuplePat {}) = False - go (SumPat {}) = False - go (ListPat {}) = False - go (LitPat _ l) = hsLitNeedsParens p l - go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol) - go (XPat {}) = True -- conservative default - --- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ --- needs parentheses under precedence @p@. -conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool -conPatNeedsParens p = go - where - go (PrefixCon args) = p >= appPrec && not (null args) - go (InfixCon {}) = p >= opPrec - go (RecCon {}) = False - --- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and --- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. -parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) -parenthesizePat p lpat@(dL->L loc pat) - | patNeedsParens p pat = cL loc (ParPat noExtField lpat) - | otherwise = lpat - -{- -% Collect all EvVars from all constructor patterns --} - --- May need to add more cases -collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar -collectEvVarsPats = unionManyBags . map collectEvVarsPat - -collectEvVarsLPat :: LPat GhcTc -> Bag EvVar -collectEvVarsLPat = collectEvVarsPat . unLoc - -collectEvVarsPat :: Pat GhcTc -> Bag EvVar -collectEvVarsPat pat = - case pat of - LazyPat _ p -> collectEvVarsLPat p - AsPat _ _ p -> collectEvVarsLPat p - ParPat _ p -> collectEvVarsLPat p - BangPat _ p -> collectEvVarsLPat p - ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps - TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps - SumPat _ p _ _ -> collectEvVarsLPat p - ConPatOut {pat_dicts = dicts, pat_args = args} - -> unionBags (listToBag dicts) - $ unionManyBags - $ map collectEvVarsLPat - $ hsConPatArgs args - SigPat _ p _ -> collectEvVarsLPat p - CoPat _ _ p _ -> collectEvVarsPat p - ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" - _other_pat -> emptyBag diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot deleted file mode 100644 index a1067d5dc5..0000000000 --- a/compiler/hsSyn/HsPat.hs-boot +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE CPP, KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} - -module HsPat where - -import Outputable -import HsExtension ( OutputableBndrId, GhcPass ) - -type role Pat nominal -data Pat (i :: *) -type LPat i = Pat i - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs deleted file mode 100644 index 622f1b9c77..0000000000 --- a/compiler/hsSyn/HsSyn.hs +++ /dev/null @@ -1,153 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section{Haskell abstract syntax definition} - -This module glues together the pieces of the Haskell abstract syntax, -which is declared in the various \tr{Hs*} modules. This module, -therefore, is almost nothing but re-exporting. --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data - -module HsSyn ( - module HsBinds, - module HsDecls, - module HsExpr, - module HsImpExp, - module HsLit, - module HsPat, - module HsTypes, - module HsUtils, - module HsDoc, - module PlaceHolder, - module HsExtension, - Fixity, - - HsModule(..), -) where - --- friends: -import GhcPrelude - -import HsDecls -import HsBinds -import HsExpr -import HsImpExp -import HsLit -import PlaceHolder -import HsExtension -import HsPat -import HsTypes -import BasicTypes ( Fixity, WarningTxt ) -import HsUtils -import HsDoc -import HsInstances () -- For Data instances - --- others: -import Outputable -import SrcLoc -import Module ( ModuleName ) - --- libraries: -import Data.Data hiding ( Fixity ) - --- | Haskell Module --- --- All we actually declare here is the top-level structure for a module. -data HsModule pass - = HsModule { - hsmodName :: Maybe (Located ModuleName), - -- ^ @Nothing@: \"module X where\" is omitted (in which case the next - -- field is Nothing too) - hsmodExports :: Maybe (Located [LIE pass]), - -- ^ Export list - -- - -- - @Nothing@: export list omitted, so export everything - -- - -- - @Just []@: export /nothing/ - -- - -- - @Just [...]@: as you would expect... - -- - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - hsmodImports :: [LImportDecl pass], - -- ^ We snaffle interesting stuff out of the imported interfaces early - -- on, adding that info to TyDecls/etc; so this list is often empty, - -- downstream. - hsmodDecls :: [LHsDecl pass], - -- ^ Type, class, value, and interface signature decls - hsmodDeprecMessage :: Maybe (Located WarningTxt), - -- ^ reason\/explanation for warning/deprecation of this module - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' - -- - - -- For details on above see note [Api annotations] in ApiAnnotation - hsmodHaddockModHeader :: Maybe LHsDocString - -- ^ Haddock module info and description, unparsed - -- - -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' - -- ,'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - } - -- ^ 'ApiAnnotation.AnnKeywordId's - -- - -- - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere' - -- - -- - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi', - -- 'ApiAnnotation.AnnClose' for explicit braces and semi around - -- hsmodImports,hsmodDecls if this style is used. - - -- For details on above see note [Api annotations] in ApiAnnotation --- deriving instance (DataIdLR name name) => Data (HsModule name) -deriving instance Data (HsModule GhcPs) -deriving instance Data (HsModule GhcRn) -deriving instance Data (HsModule GhcTc) - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where - - ppr (HsModule Nothing _ imports decls _ mbDoc) - = pp_mb mbDoc $$ pp_nonnull imports - $$ pp_nonnull decls - - ppr (HsModule (Just name) exports imports decls deprec mbDoc) - = vcat [ - pp_mb mbDoc, - case exports of - Nothing -> pp_header (text "where") - Just es -> vcat [ - pp_header lparen, - nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), - nest 4 (text ") where") - ], - pp_nonnull imports, - pp_nonnull decls - ] - where - pp_header rest = case deprec of - Nothing -> pp_modname <+> rest - Just d -> vcat [ pp_modname, ppr d, rest ] - - pp_modname = text "module" <+> ppr name - -pp_mb :: Outputable t => Maybe t -> SDoc -pp_mb (Just x) = ppr x -pp_mb Nothing = empty - -pp_nonnull :: Outputable t => [t] -> SDoc -pp_nonnull [] = empty -pp_nonnull xs = vcat (map ppr xs) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs deleted file mode 100644 index ad9c186c76..0000000000 --- a/compiler/hsSyn/HsTypes.hs +++ /dev/null @@ -1,1724 +0,0 @@ -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -HsTypes: Abstract syntax: user-defined types --} - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module HsTypes ( - HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, - HsTyVarBndr(..), LHsTyVarBndr, ForallVisFlag(..), - LHsQTyVars(..), - HsImplicitBndrs(..), - HsWildCardBndrs(..), - LHsSigType, LHsSigWcType, LHsWcType, - HsTupleSort(..), - HsContext, LHsContext, noLHsContext, - HsTyLit(..), - HsIPName(..), hsIPNameFS, - HsArg(..), numVisibleArgs, - LHsTypeArg, - - LBangType, BangType, - HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..), - getBangType, getBangStrictness, - - ConDeclField(..), LConDeclField, pprConDeclFields, - - HsConDetails(..), - - FieldOcc(..), LFieldOcc, mkFieldOcc, - AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, - rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, - unambiguousFieldOcc, ambiguousFieldOcc, - - mkAnonWildCardTy, pprAnonWildCard, - - mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, - mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, - mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, - isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, - hsScopedTvs, hsWcScopedTvs, dropWildCards, - hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, - splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, - splitLHsPatSynTy, - splitLHsForAllTy, splitLHsForAllTyInvis, - splitLHsQualTy, splitLHsSigmaTy, splitLHsSigmaTyInvis, - splitHsFunType, hsTyGetAppHead_maybe, - mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, - ignoreParens, hsSigType, hsSigWcType, - hsLTyVarBndrToType, hsLTyVarBndrsToTypes, - hsConDetailsArgs, - - -- Printing - pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll, - pprLHsContext, - hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) - -import HsExtension - -import Id ( Id ) -import Name( Name ) -import RdrName ( RdrName ) -import DataCon( HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..) ) -import TysPrim( funTyConName ) -import Type -import HsDoc -import BasicTypes -import SrcLoc -import Outputable -import FastString -import Maybes( isJust ) -import Util ( count, debugIsOn ) - -import Data.Data hiding ( Fixity, Prefix, Infix ) - -{- -************************************************************************ -* * -\subsection{Bang annotations} -* * -************************************************************************ --} - --- | Located Bang Type -type LBangType pass = Located (BangType pass) - --- | Bang Type --- --- In the parser, strictness and packedness annotations bind more tightly --- than docstrings. This means that when consuming a 'BangType' (and looking --- for 'HsBangTy') we must be ready to peer behind a potential layer of --- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example. -type BangType pass = HsType pass -- Bangs are in the HsType data type - -getBangType :: LHsType a -> LHsType a -getBangType (L _ (HsBangTy _ _ lty)) = lty -getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) = - addCLoc lty lds (HsDocTy x lty lds) -getBangType lty = lty - -getBangStrictness :: LHsType a -> HsSrcBang -getBangStrictness (L _ (HsBangTy _ s _)) = s -getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s -getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) - -{- -************************************************************************ -* * -\subsection{Data types} -* * -************************************************************************ - -This is the syntax for types as seen in type signatures. - -Note [HsBSig binder lists] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a binder (or pattern) decorated with a type or kind, - \ (x :: a -> a). blah - forall (a :: k -> *) (b :: k). blah -Then we use a LHsBndrSig on the binder, so that the -renamer can decorate it with the variables bound -by the pattern ('a' in the first example, 'k' in the second), -assuming that neither of them is in scope already -See also Note [Kind and type-variable binders] in RnTypes - -Note [HsType binders] -~~~~~~~~~~~~~~~~~~~~~ -The system for recording type and kind-variable binders in HsTypes -is a bit complicated. Here's how it works. - -* In a HsType, - HsForAllTy represents an /explicit, user-written/ 'forall' - e.g. forall a b. {...} or - forall a b -> {...} - HsQualTy represents an /explicit, user-written/ context - e.g. (Eq a, Show a) => ... - The context can be empty if that's what the user wrote - These constructors represent what the user wrote, no more - and no less. - -* The ForallVisFlag field of HsForAllTy represents whether a forall is - invisible (e.g., forall a b. {...}, with a dot) or visible - (e.g., forall a b -> {...}, with an arrow). - -* HsTyVarBndr describes a quantified type variable written by the - user. For example - f :: forall a (b :: *). blah - here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has - a list of LHsTyVarBndrs. - -* HsImplicitBndrs is a wrapper that gives the implicitly-quantified - kind and type variables of the wrapped thing. It is filled in by - the renamer. For example, if the user writes - f :: a -> a - the HsImplicitBinders binds the 'a' (not a HsForAllTy!). - NB: this implicit quantification is purely lexical: we bind any - type or kind variables that are not in scope. The type checker - may subsequently quantify over further kind variables. - -* HsWildCardBndrs is a wrapper that binds the wildcard variables - of the wrapped thing. It is filled in by the renamer - f :: _a -> _ - The enclosing HsWildCardBndrs binds the wildcards _a and _. - -* The explicit presence of these wrappers specifies, in the HsSyn, - exactly where implicit quantification is allowed, and where - wildcards are allowed. - -* LHsQTyVars is used in data/class declarations, where the user gives - explicit *type* variable bindings, but we need to implicitly bind - *kind* variables. For example - class C (a :: k -> *) where ... - The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars - -Note [The wildcard story for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Types can have wildcards in them, to support partial type signatures, -like f :: Int -> (_ , _a) -> _a - -A wildcard in a type can be - - * An anonymous wildcard, - written '_' - In HsType this is represented by HsWildCardTy. - The renamer leaves it untouched, and it is later given fresh meta tyvars in - the typechecker. - - * A named wildcard, - written '_a', '_foo', etc - In HsType this is represented by (HsTyVar "_a") - i.e. a perfectly ordinary type variable that happens - to start with an underscore - -Note carefully: - -* When NamedWildCards is off, type variables that start with an - underscore really /are/ ordinary type variables. And indeed, even - when NamedWildCards is on you can bind _a explicitly as an ordinary - type variable: - data T _a _b = MkT _b _a - Or even: - f :: forall _a. _a -> _b - Here _a is an ordinary forall'd binder, but (With NamedWildCards) - _b is a named wildcard. (See the comments in #10982) - -* Named wildcards are bound by the HsWildCardBndrs construct, which wraps - types that are allowed to have wildcards. Unnamed wildcards however are left - unchanged until typechecking, where we give them fresh wild tyavrs and - determine whether or not to emit hole constraints on each wildcard - (we don't if it's a visible type/kind argument or a type family pattern). - See related notes Note [Wildcards in visible kind application] - and Note [Wildcards in visible type application] in TcHsType.hs - -* After type checking is done, we report what types the wildcards - got unified with. - -Note [Ordering of implicit variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the advent of -XTypeApplications, GHC makes promises about the ordering -of implicit variable quantification. Specifically, we offer that implicitly -quantified variables (such as those in const :: a -> b -> a, without a `forall`) -will occur in left-to-right order of first occurrence. Here are a few examples: - - const :: a -> b -> a -- forall a b. ... - f :: Eq a => b -> a -> a -- forall a b. ... contexts are included - - type a <-< b = b -> a - g :: a <-< b -- forall a b. ... type synonyms matter - - class Functor f where - fmap :: (a -> b) -> f a -> f b -- forall f a b. ... - -- The f is quantified by the class, so only a and b are considered in fmap - -This simple story is complicated by the possibility of dependency: all variables -must come after any variables mentioned in their kinds. - - typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... - -The k comes first because a depends on k, even though the k appears later than -the a in the code. Thus, GHC does a *stable topological sort* on the variables. -By "stable", we mean that any two variables who do not depend on each other -preserve their existing left-to-right ordering. - -Implicitly bound variables are collected by the extract- family of functions -(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes. -These functions thus promise to keep left-to-right ordering. -Look for pointers to this note to see the places where the action happens. - -Note that we also maintain this ordering in kind signatures. Even though -there's no visible kind application (yet), having implicit variables be -quantified in left-to-right order in kind signatures is nice since: - -* It's consistent with the treatment for type signatures. -* It can affect how types are displayed with -fprint-explicit-kinds (see - #15568 for an example), which is a situation where knowing the order in - which implicit variables are quantified can be useful. -* In the event that visible kind application is implemented, the order in - which we would expect implicit variables to be ordered in kinds will have - already been established. --} - --- | Located Haskell Context -type LHsContext pass = Located (HsContext pass) - -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' - -- For details on above see note [Api annotations] in ApiAnnotation - -noLHsContext :: LHsContext pass --- Use this when there is no context in the original program --- It would really be more kosher to use a Maybe, to distinguish --- class () => C a where ... --- from --- class C a where ... -noLHsContext = noLoc [] - --- | Haskell Context -type HsContext pass = [LHsType pass] - --- | Located Haskell Type -type LHsType pass = Located (HsType pass) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Haskell Kind -type HsKind pass = HsType pass - --- | Located Haskell Kind -type LHsKind pass = Located (HsKind pass) - -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - --------------------------------------------------- --- LHsQTyVars --- The explicitly-quantified binders in a data/type declaration - --- | Located Haskell Type Variable Binder -type LHsTyVarBndr pass = Located (HsTyVarBndr pass) - -- See Note [HsType binders] - --- | Located Haskell Quantified Type Variables -data LHsQTyVars pass -- See Note [HsType binders] - = HsQTvs { hsq_ext :: XHsQTvs pass - - , hsq_explicit :: [LHsTyVarBndr pass] - -- Explicit variables, written by the user - -- See Note [HsForAllTy tyvar binders] - } - | XLHsQTyVars (XXLHsQTyVars pass) - -type HsQTvsRn = [Name] -- Implicit variables - -- For example, in data T (a :: k1 -> k2) = ... - -- the 'a' is explicit while 'k1', 'k2' are implicit - -type instance XHsQTvs GhcPs = NoExtField -type instance XHsQTvs GhcRn = HsQTvsRn -type instance XHsQTvs GhcTc = HsQTvsRn - -type instance XXLHsQTyVars (GhcPass _) = NoExtCon - -mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs -mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } - -hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] -hsQTvExplicit = hsq_explicit - -emptyLHsQTvs :: LHsQTyVars GhcRn -emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] } - -isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool -isEmptyLHsQTvs (HsQTvs { hsq_ext = imp, hsq_explicit = exp }) - = null imp && null exp -isEmptyLHsQTvs _ = False - ------------------------------------------------- --- HsImplicitBndrs --- Used to quantify the implicit binders of a type --- * Implicit binders of a type signature (LHsSigType/LHsSigWcType) --- * Patterns in a type/data family instance (HsTyPats) - --- | Haskell Implicit Binders -data HsImplicitBndrs pass thing -- See Note [HsType binders] - = HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name] - -- Implicitly-bound kind & type vars - -- Order is important; see - -- Note [Ordering of implicit variables] - -- in RnTypes - - , hsib_body :: thing -- Main payload (type or list of types) - } - | XHsImplicitBndrs (XXHsImplicitBndrs pass thing) - -type instance XHsIB GhcPs _ = NoExtField -type instance XHsIB GhcRn _ = [Name] -type instance XHsIB GhcTc _ = [Name] - -type instance XXHsImplicitBndrs (GhcPass _) _ = NoExtCon - --- | Haskell Wildcard Binders -data HsWildCardBndrs pass thing - -- See Note [HsType binders] - -- See Note [The wildcard story for types] - = HsWC { hswc_ext :: XHsWC pass thing - -- after the renamer - -- Wild cards, only named - -- See Note [Wildcards in visible kind application] - - , hswc_body :: thing - -- Main payload (type or list of types) - -- If there is an extra-constraints wildcard, - -- it's still there in the hsc_body. - } - | XHsWildCardBndrs (XXHsWildCardBndrs pass thing) - -type instance XHsWC GhcPs b = NoExtField -type instance XHsWC GhcRn b = [Name] -type instance XHsWC GhcTc b = [Name] - -type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon - --- | Located Haskell Signature Type -type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only - --- | Located Haskell Wildcard Type -type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only - --- | Located Haskell Signature Wildcard Type -type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both - --- See Note [Representing type signatures] - -hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing -hsImplicitBody (HsIB { hsib_body = body }) = body -hsImplicitBody (XHsImplicitBndrs nec) = noExtCon nec - -hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) -hsSigType = hsImplicitBody - -hsSigWcType :: LHsSigWcType pass -> LHsType pass -hsSigWcType sig_ty = hsib_body (hswc_body sig_ty) - -dropWildCards :: LHsSigWcType pass -> LHsSigType pass --- Drop the wildcard part of a LHsSigWcType -dropWildCards sig_ty = hswc_body sig_ty - -{- Note [Representing type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -HsSigType is used to represent an explicit user type signature -such as f :: a -> a - or g (x :: a -> a) = x - -A HsSigType is just a HsImplicitBndrs wrapping a LHsType. - * The HsImplicitBndrs binds the /implicitly/ quantified tyvars - * The LHsType binds the /explicitly/ quantified tyvars - -E.g. For a signature like - f :: forall (a::k). blah -we get - HsIB { hsib_vars = [k] - , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] - , hst_body = blah } -The implicit kind variable 'k' is bound by the HsIB; -the explicitly forall'd tyvar 'a' is bound by the HsForAllTy --} - -mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing -mkHsImplicitBndrs x = HsIB { hsib_ext = noExtField - , hsib_body = x } - -mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing -mkHsWildCardBndrs x = HsWC { hswc_body = x - , hswc_ext = noExtField } - --- Add empty binders. This is a bit suspicious; what if --- the wrapped thing had free type variables? -mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing -mkEmptyImplicitBndrs x = HsIB { hsib_ext = [] - , hsib_body = x } - -mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing -mkEmptyWildCardBndrs x = HsWC { hswc_body = x - , hswc_ext = [] } - - --------------------------------------------------- --- | These names are used early on to store the names of implicit --- parameters. They completely disappear after type-checking. -newtype HsIPName = HsIPName FastString - deriving( Eq, Data ) - -hsIPNameFS :: HsIPName -> FastString -hsIPNameFS (HsIPName n) = n - -instance Outputable HsIPName where - ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters - -instance OutputableBndr HsIPName where - pprBndr _ n = ppr n -- Simple for now - pprInfixOcc n = ppr n - pprPrefixOcc n = ppr n - --------------------------------------------------- - --- | Haskell Type Variable Binder -data HsTyVarBndr pass - = UserTyVar -- no explicit kinding - (XUserTyVar pass) - (Located (IdP pass)) - -- See Note [Located RdrNames] in HsExpr - | KindedTyVar - (XKindedTyVar pass) - (Located (IdP pass)) - (LHsKind pass) -- The user-supplied kind signature - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', - -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | XTyVarBndr - (XXTyVarBndr pass) - -type instance XUserTyVar (GhcPass _) = NoExtField -type instance XKindedTyVar (GhcPass _) = NoExtField -type instance XXTyVarBndr (GhcPass _) = NoExtCon - --- | Does this 'HsTyVarBndr' come with an explicit kind annotation? -isHsKindedTyVar :: HsTyVarBndr pass -> Bool -isHsKindedTyVar (UserTyVar {}) = False -isHsKindedTyVar (KindedTyVar {}) = True -isHsKindedTyVar (XTyVarBndr {}) = False - --- | Do all type variables in this 'LHsQTyVars' come with kind annotations? -hsTvbAllKinded :: LHsQTyVars pass -> Bool -hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit - --- | Haskell Type -data HsType pass - = HsForAllTy -- See Note [HsType binders] - { hst_xforall :: XForAllTy pass - , hst_fvf :: ForallVisFlag -- Is this `forall a -> {...}` or - -- `forall a. {...}`? - , hst_bndrs :: [LHsTyVarBndr pass] - -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType pass -- body type - } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', - -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsQualTy -- See Note [HsType binders] - { hst_xqual :: XQualTy pass - , hst_ctxt :: LHsContext pass -- Context C => blah - , hst_body :: LHsType pass } - - | HsTyVar (XTyVar pass) - PromotionFlag -- Whether explicitly promoted, - -- for the pretty printer - (Located (IdP pass)) - -- Type variable, type constructor, or data constructor - -- see Note [Promotions (HsTyVar)] - -- See Note [Located RdrNames] in HsExpr - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsAppTy (XAppTy pass) - (LHsType pass) - (LHsType pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsAppKindTy (XAppKindTy pass) -- type level type app - (LHsType pass) - (LHsKind pass) - - | HsFunTy (XFunTy pass) - (LHsType pass) -- function type - (LHsType pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsListTy (XListTy pass) - (LHsType pass) -- Element type - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsTupleTy (XTupleTy pass) - HsTupleSort - [LHsType pass] -- Element types (length gives arity) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, - -- 'ApiAnnotation.AnnClose' @')' or '#)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsSumTy (XSumTy pass) - [LHsType pass] -- Element types (length gives arity) - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, - -- 'ApiAnnotation.AnnClose' '#)'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsOpTy (XOpTy pass) - (LHsType pass) (Located (IdP pass)) (LHsType pass) - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsParTy (XParTy pass) - (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr - -- Parenthesis preserved for the precedence re-arrangement in RnTypes - -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsIParamTy (XIParamTy pass) - (Located HsIPName) -- (?x :: ty) - (LHsType pass) -- Implicit parameters as they occur in - -- contexts - -- ^ - -- > (?x :: ty) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsStarTy (XStarTy pass) - Bool -- Is this the Unicode variant? - -- Note [HsStarTy] - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - | HsKindSig (XKindSig pass) - (LHsType pass) -- (ty :: kind) - (LHsKind pass) -- A type with a kind signature - -- ^ - -- > (ty :: kind) - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, - -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsSpliceTy (XSpliceTy pass) - (HsSplice pass) -- Includes quasi-quotes - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsDocTy (XDocTy pass) - (LHsType pass) LHsDocString -- A documented type - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsBangTy (XBangTy pass) - HsSrcBang (LHsType pass) -- Bang-style type annotations - -- ^ - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, - -- 'ApiAnnotation.AnnClose' @'#-}'@ - -- 'ApiAnnotation.AnnBang' @\'!\'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsRecTy (XRecTy pass) - [LConDeclField pass] -- Only in data type declarations - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, - -- 'ApiAnnotation.AnnClose' @'}'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* - -- -- Core Type through HsSyn. - -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsExplicitListTy -- A promoted explicit list - (XExplicitListTy pass) - PromotionFlag -- whether explcitly promoted, for pretty printer - [LHsType pass] - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, - -- 'ApiAnnotation.AnnClose' @']'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsExplicitTupleTy -- A promoted explicit tuple - (XExplicitTupleTy pass) - [LHsType pass] - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, - -- 'ApiAnnotation.AnnClose' @')'@ - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - | HsWildCardTy (XWildCardTy pass) -- A type wildcard - -- See Note [The wildcard story for types] - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - - -- For details on above see note [Api annotations] in ApiAnnotation - - -- For adding new constructors via Trees that Grow - | XHsType - (XXType pass) - -data NewHsTypeX - = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* - -- Core Type through HsSyn. - deriving Data - -- ^ - 'ApiAnnotation.AnnKeywordId' : None - -instance Outputable NewHsTypeX where - ppr (NHsCoreTy ty) = ppr ty - -type instance XForAllTy (GhcPass _) = NoExtField -type instance XQualTy (GhcPass _) = NoExtField -type instance XTyVar (GhcPass _) = NoExtField -type instance XAppTy (GhcPass _) = NoExtField -type instance XFunTy (GhcPass _) = NoExtField -type instance XListTy (GhcPass _) = NoExtField -type instance XTupleTy (GhcPass _) = NoExtField -type instance XSumTy (GhcPass _) = NoExtField -type instance XOpTy (GhcPass _) = NoExtField -type instance XParTy (GhcPass _) = NoExtField -type instance XIParamTy (GhcPass _) = NoExtField -type instance XStarTy (GhcPass _) = NoExtField -type instance XKindSig (GhcPass _) = NoExtField - -type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives - -type instance XSpliceTy GhcPs = NoExtField -type instance XSpliceTy GhcRn = NoExtField -type instance XSpliceTy GhcTc = Kind - -type instance XDocTy (GhcPass _) = NoExtField -type instance XBangTy (GhcPass _) = NoExtField -type instance XRecTy (GhcPass _) = NoExtField - -type instance XExplicitListTy GhcPs = NoExtField -type instance XExplicitListTy GhcRn = NoExtField -type instance XExplicitListTy GhcTc = Kind - -type instance XExplicitTupleTy GhcPs = NoExtField -type instance XExplicitTupleTy GhcRn = NoExtField -type instance XExplicitTupleTy GhcTc = [Kind] - -type instance XTyLit (GhcPass _) = NoExtField - -type instance XWildCardTy (GhcPass _) = NoExtField - -type instance XXType (GhcPass _) = NewHsTypeX - - --- Note [Literal source text] in BasicTypes for SourceText fields in --- the following --- | Haskell Type Literal -data HsTyLit - = HsNumTy SourceText Integer - | HsStrTy SourceText FastString - deriving Data - - -{- -Note [HsForAllTy tyvar binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After parsing: - * Implicit => empty - Explicit => the variables the user wrote - -After renaming - * Implicit => the *type* variables free in the type - Explicit => the variables the user wrote (renamed) - -Qualified currently behaves exactly as Implicit, -but it is deprecated to use it for implicit quantification. -In this case, GHC 7.10 gives a warning; see -Note [Context quantification] in RnTypes, and #4426. -In GHC 8.0, Qualified will no longer bind variables -and this will become an error. - -The kind variables bound in the hsq_implicit field come both - a) from the kind signatures on the kind vars (eg k1) - b) from the scope of the forall (eg k2) -Example: f :: forall (a::k1) b. T a (b::k2) - - -Note [Unit tuples] -~~~~~~~~~~~~~~~~~~ -Consider the type - type instance F Int = () -We want to parse that "()" - as HsTupleTy HsBoxedOrConstraintTuple [], -NOT as HsTyVar unitTyCon - -Why? Because F might have kind (* -> Constraint), so we when parsing we -don't know if that tuple is going to be a constraint tuple or an ordinary -unit tuple. The HsTupleSort flag is specifically designed to deal with -that, but it has to work for unit tuples too. - -Note [Promotions (HsTyVar)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -HsTyVar: A name in a type or kind. - Here are the allowed namespaces for the name. - In a type: - Var: not allowed - Data: promoted data constructor - Tv: type variable - TcCls before renamer: type constructor, class constructor, or promoted data constructor - TcCls after renamer: type constructor or class constructor - In a kind: - Var, Data: not allowed - Tv: kind variable - TcCls: kind constructor or promoted type constructor - - The 'Promoted' field in an HsTyVar captures whether the type was promoted in - the source code by prefixing an apostrophe. - -Note [HsStarTy] -~~~~~~~~~~~~~~~ -When the StarIsType extension is enabled, we want to treat '*' and its Unicode -variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser -would mean that when we pretty-print it back, we don't know whether the user -wrote '*' or 'Type', and lose the parse/ppr roundtrip property. - -As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') -and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type). -When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not -involved. - - -Note [Promoted lists and tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice the difference between - HsListTy HsExplicitListTy - HsTupleTy HsExplicitListTupleTy - -E.g. f :: [Int] HsListTy - - g3 :: T '[] All these use - g2 :: T '[True] HsExplicitListTy - g1 :: T '[True,False] - g1a :: T [True,False] (can omit ' where unambiguous) - - kind of T :: [Bool] -> * This kind uses HsListTy! - -E.g. h :: (Int,Bool) HsTupleTy; f is a pair - k :: S '(True,False) HsExplicitTypleTy; S is indexed by - a type-level pair of booleans - kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy - -Note [Distinguishing tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Apart from promotion, tuples can have one of three different kinds: - - x :: (Int, Bool) -- Regular boxed tuples - f :: Int# -> (# Int#, Int# #) -- Unboxed tuples - g :: (Eq a, Ord a) => a -- Constraint tuples - -For convenience, internally we use a single constructor for all of these, -namely HsTupleTy, but keep track of the tuple kind (in the first argument to -HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, -because of the #. However, with -XConstraintKinds we can only distinguish -between constraint and boxed tuples during type checking, in general. Hence the -four constructors of HsTupleSort: - - HsUnboxedTuple -> Produced by the parser - HsBoxedTuple -> Certainly a boxed tuple - HsConstraintTuple -> Certainly a constraint tuple - HsBoxedOrConstraintTuple -> Could be a boxed or a constraint - tuple. Produced by the parser only, - disappears after type checking --} - --- | Haskell Tuple Sort -data HsTupleSort = HsUnboxedTuple - | HsBoxedTuple - | HsConstraintTuple - | HsBoxedOrConstraintTuple - deriving Data - --- | Located Constructor Declaration Field -type LConDeclField pass = Located (ConDeclField pass) - -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when - -- in a list - - -- For details on above see note [Api annotations] in ApiAnnotation - --- | Constructor Declaration Field -data ConDeclField pass -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_ext :: XConDeclField pass, - cd_fld_names :: [LFieldOcc pass], - -- ^ See Note [ConDeclField passs] - cd_fld_type :: LBangType pass, - cd_fld_doc :: Maybe LHsDocString } - -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | XConDeclField (XXConDeclField pass) - -type instance XConDeclField (GhcPass _) = NoExtField -type instance XXConDeclField (GhcPass _) = NoExtCon - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (ConDeclField p) where - ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty - ppr (XConDeclField x) = ppr x - --- HsConDetails is used for patterns/expressions *and* for data type --- declarations --- | Haskell Constructor Details -data HsConDetails arg rec - = PrefixCon [arg] -- C p1 p2 p3 - | RecCon rec -- C { x = p1, y = p2 } - | InfixCon arg arg -- p1 `C` p2 - deriving Data - -instance (Outputable arg, Outputable rec) - => Outputable (HsConDetails arg rec) where - ppr (PrefixCon args) = text "PrefixCon" <+> ppr args - ppr (RecCon rec) = text "RecCon:" <+> ppr rec - ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] - -hsConDetailsArgs :: - HsConDetails (LHsType a) (Located [LConDeclField a]) - -> [LHsType a] -hsConDetailsArgs details = case details of - InfixCon a b -> [a,b] - PrefixCon xs -> xs - RecCon r -> map (cd_fld_type . unLoc) (unLoc r) - -{- -Note [ConDeclField passs] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -A ConDeclField contains a list of field occurrences: these always -include the field label as the user wrote it. After the renamer, it -will additionally contain the identity of the selector function in the -second component. - -Due to DuplicateRecordFields, the OccName of the selector function -may have been mangled, which is why we keep the original field label -separately. For example, when DuplicateRecordFields is enabled - - data T = MkT { x :: Int } - -gives - - ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. --} - ------------------------ --- A valid type must have a for-all at the top of the type, or of the fn arg --- types - ---------------------- -hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] --- Get the lexically-scoped type variables of a HsSigType --- - the explicitly-given forall'd type variables --- - the named wildcars; see Note [Scoping of named wildcards] --- because they scope in the same way -hsWcScopedTvs sig_ty - | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty - , HsIB { hsib_ext = vars - , hsib_body = sig_ty2 } <- sig_ty1 - = case sig_ty2 of - L _ (HsForAllTy { hst_fvf = vis_flag - , hst_bndrs = tvs }) -> - ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] - vars ++ nwcs ++ hsLTyVarNames tvs - _ -> nwcs -hsWcScopedTvs (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec -hsWcScopedTvs (XHsWildCardBndrs nec) = noExtCon nec - -hsScopedTvs :: LHsSigType GhcRn -> [Name] --- Same as hsWcScopedTvs, but for a LHsSigType -hsScopedTvs sig_ty - | HsIB { hsib_ext = vars - , hsib_body = sig_ty2 } <- sig_ty - , L _ (HsForAllTy { hst_fvf = vis_flag - , hst_bndrs = tvs }) <- sig_ty2 - = ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag] - vars ++ hsLTyVarNames tvs - | otherwise - = [] - -{- Note [Scoping of named wildcards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: _a -> _a - f x = let g :: _a -> _a - g = ... - in ... - -Currently, for better or worse, the "_a" variables are all the same. So -although there is no explicit forall, the "_a" scopes over the definition. -I don't know if this is a good idea, but there it is. --} - -{- Note [hsScopedTvs vis_flag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --XScopedTypeVariables can be defined in terms of a desugaring to --XTypeAbstractions (GHC Proposal #50): - - fn :: forall a b c. tau(a,b,c) fn :: forall a b c. tau(a,b,c) - fn = defn(a,b,c) ==> fn @x @y @z = defn(x,y,z) - -That is, for every type variable of the leading 'forall' in the type signature, -we add an invisible binder at term level. - -This model does not extend to visible forall, as discussed here: - -* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412 -* https://github.com/ghc-proposals/ghc-proposals/pull/238 - -The conclusion of these discussions can be summarized as follows: - - > Assuming support for visible 'forall' in terms, consider this example: - > - > vfn :: forall x y -> tau(x,y) - > vfn = \a b -> ... - > - > The user has written their own binders 'a' and 'b' to stand for 'x' and - > 'y', and we definitely should not desugar this into: - > - > vfn :: forall x y -> tau(x,y) - > vfn x y = \a b -> ... -- bad! - -At the moment, GHC does not support visible 'forall' in terms, so we simply cement -our assumptions with an assert: - - hsScopedTvs (HsForAllTy { hst_fvf = vis_flag, ... }) = - ASSERT( vis_flag == ForallInvis ) - ... - -In the future, this assert can be safely turned into a pattern match to support -visible forall in terms: - - hsScopedTvs (HsForAllTy { hst_fvf = ForallInvis, ... }) = ... --} - ---------------------- -hsTyVarName :: HsTyVarBndr (GhcPass p) -> IdP (GhcPass p) -hsTyVarName (UserTyVar _ (L _ n)) = n -hsTyVarName (KindedTyVar _ (L _ n) _) = n -hsTyVarName (XTyVarBndr nec) = noExtCon nec - -hsLTyVarName :: LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p) -hsLTyVarName = hsTyVarName . unLoc - -hsLTyVarNames :: [LHsTyVarBndr (GhcPass p)] -> [IdP (GhcPass p)] -hsLTyVarNames = map hsLTyVarName - -hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] --- Explicit variables only -hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) - -hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] --- All variables -hsAllLTyVarNames (HsQTvs { hsq_ext = kvs - , hsq_explicit = tvs }) - = kvs ++ hsLTyVarNames tvs -hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec - -hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) -hsLTyVarLocName = onHasSrcSpan hsTyVarName - -hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] -hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) - --- | Convert a LHsTyVarBndr to an equivalent LHsType. -hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) -hsLTyVarBndrToType = onHasSrcSpan cvt - where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n - cvt (KindedTyVar _ (L name_loc n) kind) - = HsKindSig noExtField - (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind - cvt (XTyVarBndr nec) = noExtCon nec - --- | Convert a LHsTyVarBndrs to a list of types. --- Works on *type* variable only, no kind vars. -hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] -hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs -hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec - ---------------------- -ignoreParens :: LHsType pass -> LHsType pass -ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty -ignoreParens ty = ty - -isLHsForAllTy :: LHsType p -> Bool -isLHsForAllTy (L _ (HsForAllTy {})) = True -isLHsForAllTy _ = False - -{- -************************************************************************ -* * - Building types -* * -************************************************************************ --} - -mkAnonWildCardTy :: HsType GhcPs -mkAnonWildCardTy = HsWildCardTy noExtField - -mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) - -> LHsType (GhcPass p) -> HsType (GhcPass p) -mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2 - -mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppTy t1 t2 - = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) - -mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] - -> LHsType (GhcPass p) -mkHsAppTys = foldl' mkHsAppTy - -mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) - -> LHsType (GhcPass p) -mkHsAppKindTy ext ty k - = addCLoc ty k (HsAppKindTy ext ty k) - -{- -************************************************************************ -* * - Decomposing HsTypes -* * -************************************************************************ --} - ---------------------------------- --- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) --- Breaks up any parens in the result type: --- splitHsFunType (a -> (b -> c)) = ([a,b], c) --- Also deals with (->) t1 t2; that is why it only works on LHsType Name --- (see #9096) -splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) -splitHsFunType (L _ (HsParTy _ ty)) - = splitHsFunType ty - -splitHsFunType (L _ (HsFunTy _ x y)) - | (args, res) <- splitHsFunType y - = (x:args, res) -{- This is not so correct, because it won't work with visible kind app, in case - someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing - ConDeclGADT abstract syntax -} -splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) - = go t1 [t2] - where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName - , [t1,t2] <- tys - , (args, res) <- splitHsFunType t2 - = (t1:args, res) - go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys) - go (L _ (HsParTy _ ty)) tys = go ty tys - go _ _ = ([], orig_ty) -- Failure to match - -splitHsFunType other = ([], other) - --- retrieve the name of the "head" of a nested type application --- somewhat like splitHsAppTys, but a little more thorough --- used to examine the result of a GADT-like datacon, so it doesn't handle --- *all* cases (like lists, tuples, (~), etc.) -hsTyGetAppHead_maybe :: LHsType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p))) -hsTyGetAppHead_maybe = go - where - go (L _ (HsTyVar _ _ ln)) = Just ln - go (L _ (HsAppTy _ l _)) = go l - go (L _ (HsAppKindTy _ t _)) = go t - go (L _ (HsOpTy _ _ (L loc n) _)) = Just (L loc n) - go (L _ (HsParTy _ t)) = go t - go (L _ (HsKindSig _ t _)) = go t - go _ = Nothing - ------------------------------------------------------------- --- Arguments in an expression/type after splitting -data HsArg tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) - -- SrcSpan is location of the `@` - | HsArgPar SrcSpan -- See Note [HsArgPar] - -numVisibleArgs :: [HsArg tm ty] -> Arity -numVisibleArgs = count is_vis - where is_vis (HsValArg _) = True - is_vis _ = False - --- type level equivalent -type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) - -instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where - ppr (HsValArg tm) = ppr tm - ppr (HsTypeArg _ ty) = char '@' <> ppr ty - ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp -{- -Note [HsArgPar] -A HsArgPar indicates that everything to the left of this in the argument list is -enclosed in parentheses together with the function itself. It is necessary so -that we can recreate the parenthesis structure in the original source after -typechecking the arguments. - -The SrcSpan is the span of the original HsPar - -((f arg1) arg2 arg3) results in an input argument list of -[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] - --} - --------------------------------- - --- | Decompose a pattern synonym type signature into its constituent parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsPatSynTy :: LHsType pass - -> ( [LHsTyVarBndr pass] -- universals - , LHsContext pass -- required constraints - , [LHsTyVarBndr pass] -- existentials - , LHsContext pass -- provided constraints - , LHsType pass) -- body type -splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) - where - (univs, ty1) = splitLHsForAllTyInvis ty - (reqs, ty2) = splitLHsQualTy ty1 - (exis, ty3) = splitLHsForAllTyInvis ty2 - (provs, ty4) = splitLHsQualTy ty3 - --- | Decompose a sigma type (of the form @forall . context => body@) --- into its constituent parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsSigmaTy :: LHsType pass - -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) -splitLHsSigmaTy ty - | (tvs, ty1) <- splitLHsForAllTy ty - , (ctxt, ty2) <- splitLHsQualTy ty1 - = (tvs, ctxt, ty2) - --- | Like 'splitLHsSigmaTy', but only splits type variable binders that were --- quantified invisibly (e.g., @forall a.@, with a dot). --- --- This function is used to split apart certain types, such as instance --- declaration types, which disallow visible @forall@s. For instance, if GHC --- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that --- declaration would mistakenly be accepted! --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsSigmaTyInvis :: LHsType pass - -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) -splitLHsSigmaTyInvis ty - | (tvs, ty1) <- splitLHsForAllTyInvis ty - , (ctxt, ty2) <- splitLHsQualTy ty1 - = (tvs, ctxt, ty2) - --- | Decompose a type of the form @forall . body@) into its constituent --- parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) -splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty -splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) -splitLHsForAllTy body = ([], body) - --- | Like 'splitLHsForAllTy', but only splits type variable binders that --- were quantified invisibly (e.g., @forall a.@, with a dot). --- --- This function is used to split apart certain types, such as instance --- declaration types, which disallow visible @forall@s. For instance, if GHC --- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that --- declaration would mistakenly be accepted! --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall a. <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) -splitLHsForAllTyInvis lty@(L _ ty) = - case ty of - HsParTy _ ty' -> splitLHsForAllTyInvis ty' - HsForAllTy { hst_fvf = fvf', hst_bndrs = tvs', hst_body = body' } - | fvf' == ForallInvis - -> (tvs', body') - _ -> ([], lty) - --- | Decompose a type of the form @context => body@ into its constituent parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(context => <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) -splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty -splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) -splitLHsQualTy body = (noLHsContext, body) - --- | Decompose a type class instance type (of the form --- @forall . context => instance_head@) into its constituent parts. --- --- Note that this function looks through parentheses, so it will work on types --- such as @(forall . <...>)@. The downside to this is that it is not --- generally possible to take the returned types and reconstruct the original --- type (parentheses and all) from them. -splitLHsInstDeclTy :: LHsSigType GhcRn - -> ([Name], LHsContext GhcRn, LHsType GhcRn) --- Split up an instance decl type, returning the pieces -splitLHsInstDeclTy (HsIB { hsib_ext = itkvs - , hsib_body = inst_ty }) - | (tvs, cxt, body_ty) <- splitLHsSigmaTyInvis inst_ty - = (itkvs ++ hsLTyVarNames tvs, cxt, body_ty) - -- Return implicitly bound type and kind vars - -- For an instance decl, all of them are in scope -splitLHsInstDeclTy (XHsImplicitBndrs nec) = noExtCon nec - -getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p) -getLHsInstDeclHead inst_ty - | (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty) - = body_ty - -getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p))) --- Works on (HsSigType RdrName) -getLHsInstDeclClass_maybe inst_ty - = do { let head_ty = getLHsInstDeclHead inst_ty - ; cls <- hsTyGetAppHead_maybe head_ty - ; return cls } - -{- -************************************************************************ -* * - FieldOcc -* * -************************************************************************ --} - --- | Located Field Occurrence -type LFieldOcc pass = Located (FieldOcc pass) - --- | Field Occurrence --- --- Represents an *occurrence* of an unambiguous field. We store --- both the 'RdrName' the user originally wrote, and after the --- renamer, the selector function. -data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass - , rdrNameFieldOcc :: Located RdrName - -- ^ See Note [Located RdrNames] in HsExpr - } - - | XFieldOcc - (XXFieldOcc pass) -deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) -deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) - -type instance XCFieldOcc GhcPs = NoExtField -type instance XCFieldOcc GhcRn = Name -type instance XCFieldOcc GhcTc = Id - -type instance XXFieldOcc (GhcPass _) = NoExtCon - -instance Outputable (FieldOcc pass) where - ppr = ppr . rdrNameFieldOcc - -mkFieldOcc :: Located RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc noExtField rdr - - --- | Ambiguous Field Occurrence --- --- Represents an *occurrence* of a field that is potentially --- ambiguous after the renamer, with the ambiguity resolved by the --- typechecker. We always store the 'RdrName' that the user --- originally wrote, and store the selector function after the renamer --- (for unambiguous occurrences) or the typechecker (for ambiguous --- occurrences). --- --- See Note [HsRecField and HsRecUpdField] in HsPat and --- Note [Disambiguating record fields] in TcExpr. --- See Note [Located RdrNames] in HsExpr -data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (Located RdrName) - | Ambiguous (XAmbiguous pass) (Located RdrName) - | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) - -type instance XUnambiguous GhcPs = NoExtField -type instance XUnambiguous GhcRn = Name -type instance XUnambiguous GhcTc = Id - -type instance XAmbiguous GhcPs = NoExtField -type instance XAmbiguous GhcRn = NoExtField -type instance XAmbiguous GhcTc = Id - -type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon - -instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where - ppr = ppr . rdrNameAmbiguousFieldOcc - -instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where - pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc - pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc - -mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs -mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr - -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName -rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc nec) - = noExtCon nec - -selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id -selectorAmbiguousFieldOcc (Unambiguous sel _) = sel -selectorAmbiguousFieldOcc (Ambiguous sel _) = sel -selectorAmbiguousFieldOcc (XAmbiguousFieldOcc nec) - = noExtCon nec - -unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc -unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec - -ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc -ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr -ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec - -{- -************************************************************************ -* * -\subsection{Pretty printing} -* * -************************************************************************ --} - -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where - ppr ty = pprHsType ty - -instance Outputable HsTyLit where - ppr = ppr_tylit - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (LHsQTyVars p) where - ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs - ppr (XLHsQTyVars x) = ppr x - -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsTyVarBndr p) where - ppr (UserTyVar _ n) = ppr n - ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] - ppr (XTyVarBndr n) = ppr n - -instance (p ~ GhcPass pass,Outputable thing) - => Outputable (HsImplicitBndrs p thing) where - ppr (HsIB { hsib_body = ty }) = ppr ty - ppr (XHsImplicitBndrs x) = ppr x - -instance (p ~ GhcPass pass,Outputable thing) - => Outputable (HsWildCardBndrs p thing) where - ppr (HsWC { hswc_body = ty }) = ppr ty - ppr (XHsWildCardBndrs x) = ppr x - -pprAnonWildCard :: SDoc -pprAnonWildCard = char '_' - --- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ --- only when @-dppr-debug@ is enabled. -pprHsForAll :: (OutputableBndrId (GhcPass p)) - => ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] - -> LHsContext (GhcPass p) -> SDoc -pprHsForAll = pprHsForAllExtra Nothing - --- | Version of 'pprHsForAll' that can also print an extra-constraints --- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This --- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just' --- containing the location of the extra-constraints wildcard. A special --- function for this is needed, as the extra-constraints wildcard is removed --- from the actual context and type, and stored in a separate field, thus just --- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (OutputableBndrId (GhcPass p)) - => Maybe SrcSpan -> ForallVisFlag - -> [LHsTyVarBndr (GhcPass p)] - -> LHsContext (GhcPass p) -> SDoc -pprHsForAllExtra extra fvf qtvs cxt - = pp_forall <+> pprLHsContextExtra (isJust extra) cxt - where - pp_forall | null qtvs = whenPprDebug (forAllLit <> separator) - | otherwise = forAllLit <+> interppSP qtvs <> separator - - separator = ppr_forall_separator fvf - --- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print --- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing' -pprHsExplicitForAll :: (OutputableBndrId (GhcPass p)) - => ForallVisFlag - -> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc -pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs - <> ppr_forall_separator fvf -pprHsExplicitForAll _ Nothing = empty - --- | Prints an arrow for visible @forall@s (e.g., @forall a ->@) and a dot for --- invisible @forall@s (e.g., @forall a.@). -ppr_forall_separator :: ForallVisFlag -> SDoc -ppr_forall_separator ForallVis = space <> arrow -ppr_forall_separator ForallInvis = dot - -pprLHsContext :: (OutputableBndrId (GhcPass p)) - => LHsContext (GhcPass p) -> SDoc -pprLHsContext lctxt - | null (unLoc lctxt) = empty - | otherwise = pprLHsContextAlways lctxt - --- For use in a HsQualTy, which always gets printed if it exists. -pprLHsContextAlways :: (OutputableBndrId (GhcPass p)) - => LHsContext (GhcPass p) -> SDoc -pprLHsContextAlways (L _ ctxt) - = case ctxt of - [] -> parens empty <+> darrow - [L _ ty] -> ppr_mono_ty ty <+> darrow - _ -> parens (interpp'SP ctxt) <+> darrow - --- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprLHsContextExtra :: (OutputableBndrId (GhcPass p)) - => Bool -> LHsContext (GhcPass p) -> SDoc -pprLHsContextExtra show_extra lctxt@(L _ ctxt) - | not show_extra = pprLHsContext lctxt - | null ctxt = char '_' <+> darrow - | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow - where - ctxt' = map ppr ctxt ++ [char '_'] - -pprConDeclFields :: (OutputableBndrId (GhcPass p)) - => [LConDeclField (GhcPass p)] -> SDoc -pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) - where - ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, - cd_fld_doc = doc })) - = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc - ppr_fld (L _ (XConDeclField x)) = ppr x - ppr_names [n] = ppr n - ppr_names ns = sep (punctuate comma (map ppr ns)) - -{- -Note [Printing KindedTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#3830 reminded me that we should really only print the kind -signature on a KindedTyVar if the kind signature was put there by the -programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, -rather than converting to KindedTyVars as before. - -(As it happens, the message in #3830 comes out a different way now, -and the problem doesn't show up; but having the flag on a KindedTyVar -seems like the Right Thing anyway.) --} - --- Printing works more-or-less as for Types - -pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc -pprHsType ty = ppr_mono_ty ty - -ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc -ppr_mono_lty ty = ppr_mono_ty (unLoc ty) - -ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc -ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }) - = sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty] - -ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) - = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] - -ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty -ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds -ppr_mono_ty (HsTyVar _ prom (L _ name)) - | isPromoted prom = quote (pprPrefixOcc name) - | otherwise = pprPrefixOcc name -ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 -ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys) - where std_con = case con of - HsUnboxedTuple -> UnboxedTuple - _ -> BoxedTuple -ppr_mono_ty (HsSumTy _ tys) - = tupleParens UnboxedTuple (pprWithBars ppr tys) -ppr_mono_ty (HsKindSig _ ty kind) - = ppr_mono_lty ty <+> dcolon <+> ppr kind -ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) -ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) -ppr_mono_ty (HsSpliceTy _ s) = pprSplice s -ppr_mono_ty (HsExplicitListTy _ prom tys) - | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) - | otherwise = brackets (interpp'SP tys) -ppr_mono_ty (HsExplicitTupleTy _ tys) - = quote $ parens (maybeAddSpace tys $ interpp'SP tys) -ppr_mono_ty (HsTyLit _ t) = ppr_tylit t -ppr_mono_ty (HsWildCardTy {}) = char '_' - -ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') - -ppr_mono_ty (HsAppTy _ fun_ty arg_ty) - = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] -ppr_mono_ty (HsAppKindTy _ ty k) - = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k -ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) - = sep [ ppr_mono_lty ty1 - , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] - -ppr_mono_ty (HsParTy _ ty) - = parens (ppr_mono_lty ty) - -- Put the parens in where the user did - -- But we still use the precedence stuff to add parens because - -- toHsType doesn't put in any HsParTys, so we may still need them - -ppr_mono_ty (HsDocTy _ ty doc) - -- AZ: Should we add parens? Should we introduce "-- ^"? - = ppr_mono_lty ty <+> ppr (unLoc doc) - -- we pretty print Haddock comments on types as if they were - -- postfix operators - -ppr_mono_ty (XHsType t) = ppr t - --------------------------- -ppr_fun_ty :: (OutputableBndrId (GhcPass p)) - => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc -ppr_fun_ty ty1 ty2 - = let p1 = ppr_mono_lty ty1 - p2 = ppr_mono_lty ty2 - in - sep [p1, arrow <+> p2] - --------------------------- -ppr_tylit :: HsTyLit -> SDoc -ppr_tylit (HsNumTy _ i) = integer i -ppr_tylit (HsStrTy _ s) = text (show s) - - --- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses --- under precedence @p@. -hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool -hsTypeNeedsParens p = go - where - go (HsForAllTy{}) = p >= funPrec - go (HsQualTy{}) = p >= funPrec - go (HsBangTy{}) = p > topPrec - go (HsRecTy{}) = False - go (HsTyVar{}) = False - go (HsFunTy{}) = p >= funPrec - go (HsTupleTy{}) = False - go (HsSumTy{}) = False - go (HsKindSig{}) = p >= sigPrec - go (HsListTy{}) = False - go (HsIParamTy{}) = p > topPrec - go (HsSpliceTy{}) = False - go (HsExplicitListTy{}) = False - go (HsExplicitTupleTy{}) = False - go (HsTyLit{}) = False - go (HsWildCardTy{}) = False - go (HsStarTy{}) = False - go (HsAppTy{}) = p >= appPrec - go (HsAppKindTy{}) = p >= appPrec - go (HsOpTy{}) = p >= opPrec - go (HsParTy{}) = False - go (HsDocTy _ (L _ t) _) = go t - go (XHsType{}) = False - -maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc --- See Note [Printing promoted type constructors] --- in IfaceType. This code implements the same --- logic for printing HsType -maybeAddSpace tys doc - | (ty : _) <- tys - , lhsTypeHasLeadingPromotionQuote ty = space <> doc - | otherwise = doc - -lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool -lhsTypeHasLeadingPromotionQuote ty - = goL ty - where - goL (L _ ty) = go ty - - go (HsForAllTy{}) = False - go (HsQualTy{ hst_ctxt = ctxt, hst_body = body}) - | L _ (c:_) <- ctxt = goL c - | otherwise = goL body - go (HsBangTy{}) = False - go (HsRecTy{}) = False - go (HsTyVar _ p _) = isPromoted p - go (HsFunTy _ arg _) = goL arg - go (HsListTy{}) = False - go (HsTupleTy{}) = False - go (HsSumTy{}) = False - go (HsOpTy _ t1 _ _) = goL t1 - go (HsKindSig _ t _) = goL t - go (HsIParamTy{}) = False - go (HsSpliceTy{}) = False - go (HsExplicitListTy _ p _) = isPromoted p - go (HsExplicitTupleTy{}) = True - go (HsTyLit{}) = False - go (HsWildCardTy{}) = False - go (HsStarTy{}) = False - go (HsAppTy _ t _) = goL t - go (HsAppKindTy _ t _) = goL t - go (HsParTy{}) = False - go (HsDocTy _ t _) = goL t - go (XHsType{}) = False - --- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is --- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply --- returns @ty@. -parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) -parenthesizeHsType p lty@(L loc ty) - | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty) - | otherwise = lty - --- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint --- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ --- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply --- returns @ctxt@ unchanged. -parenthesizeHsContext :: PprPrec - -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) -parenthesizeHsContext p lctxt@(L loc ctxt) = - case ctxt of - [c] -> L loc [parenthesizeHsType p c] - _ -> lctxt -- Other contexts are already "parenthesized" by virtue of - -- being tuples. diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs deleted file mode 100644 index f3bba0d6a8..0000000000 --- a/compiler/hsSyn/HsUtils.hs +++ /dev/null @@ -1,1416 +0,0 @@ -{- -(c) The University of Glasgow, 1992-2006 - - -Here we collect a variety of helper functions that construct or -analyse HsSyn. All these functions deal with generic HsSyn; functions -which deal with the instantiated versions are located elsewhere: - - Parameterised by Module - ---------------- ------------- - GhcPs/RdrName parser/RdrHsSyn - GhcRn/Name rename/RnHsSyn - GhcTc/Id typecheck/TcHsSyn --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module HsUtils( - -- Terms - mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt, - mkSimpleMatch, unguardedGRHSs, unguardedRHS, - mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, - mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, - mkHsDictLet, mkHsLams, - mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, - mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, - mkHsCmdIf, - - nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, - nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, - nlHsIntLit, nlHsVarApps, - nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, - mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - typeToLHsType, - - -- * Constructing general big tuples - -- $big_tuples - mkChunkified, chunkify, - - -- Bindings - mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, - mkPatSynBind, - isInfixFunBind, - - -- Literals - mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, - - -- Patterns - mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, - nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, - nlWildPatName, nlTuplePat, mkParPat, nlParPat, - mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, - - -- Types - mkHsAppTy, mkHsAppKindTy, - mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv, - nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, - - -- Stmts - mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt, - mkLastStmt, - emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, - emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, - unitRecStmtTc, - - -- Template Haskell - mkUntypedSplice, mkTypedSplice, - mkHsQuasiQuote, unqualQuasiQuote, - - -- Collecting binders - isUnliftedHsBind, isBangedHsBind, - - collectLocalBinders, collectHsValBinders, collectHsBindListBinders, - collectHsIdBinders, - collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, - collectPatBinders, collectPatsBinders, - collectLStmtsBinders, collectStmtsBinders, - collectLStmtBinders, collectStmtBinders, - - hsLTyClDeclBinders, hsTyClForeignBinders, - hsPatSynSelectors, getPatSynBinds, - hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, - - -- Collecting implicit binders - lStmtsImplicits, hsValBindsImplicits, lPatImplicits - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import HsDecls -import HsBinds -import HsExpr -import HsPat -import HsTypes -import HsLit -import PlaceHolder -import HsExtension - -import TcEvidence -import RdrName -import Var -import TyCoRep -import Type ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig ) -import TysWiredIn ( unitTy ) -import TcType -import DataCon -import ConLike -import Id -import Name -import NameSet hiding ( unitFV ) -import NameEnv -import BasicTypes -import SrcLoc -import FastString -import Util -import Bag -import Outputable -import Constants - -import Data.Either -import Data.Function -import Data.List - -{- -************************************************************************ -* * - Some useful helpers for constructing syntax -* * -************************************************************************ - -These functions attempt to construct a not-completely-useless SrcSpan -from their components, compared with the nl* functions below which -just attach noSrcSpan to everything. --} - -mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = cL (getLoc e) (HsPar noExtField e) - -mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) - -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) - -> LMatch (GhcPass p) (Located (body (GhcPass p))) -mkSimpleMatch ctxt pats rhs - = cL loc $ - Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats - , m_grhss = unguardedGRHSs rhs } - where - loc = case pats of - [] -> getLoc rhs - (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) - -unguardedGRHSs :: Located (body (GhcPass p)) - -> GRHSs (GhcPass p) (Located (body (GhcPass p))) -unguardedGRHSs rhs@(dL->L loc _) - = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds) - -unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) - -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] -unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)] - -mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField) - => Origin -> [LMatch name (Located (body name))] - -> MatchGroup name (Located (body name)) -mkMatchGroup origin matches = MG { mg_ext = noExtField - , mg_alts = mkLocatedList matches - , mg_origin = origin } - -mkLocatedList :: [Located a] -> Located [Located a] -mkLocatedList [] = noLoc [] -mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms - -mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2) - -mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn) - => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id) -mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) - where - t_body = hswc_body t - paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } - -mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn -mkHsAppTypes = foldl' mkHsAppType - -mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => - [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches)) - where - matches = mkMatchGroup Generated - [mkSimpleMatch LambdaExpr pats' body] - pats' = map (parenthesizePat appPrec) pats - -mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc -mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars - <.> mkWpLams dicts) expr - --- |A simple case alternative with a single pattern, no binds, no guards; --- pre-typechecking -mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) - -> LMatch (GhcPass p) (Located (body (GhcPass p))) -mkHsCaseAlt pat expr - = mkSimpleMatch CaseAlt [pat] expr - -nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) -nlHsTyApp fun_id tys - = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id))) - -nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] - -> LHsExpr (GhcPass id) -nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs - ---------- Adding parens --------- -mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) --- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them --- So 'f x' becomes '(f x)', but '3' stays as '3' -mkLHsPar le@(dL->L loc e) - | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le) - | otherwise = le - -mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -mkParPat lp@(dL->L loc p) - | patNeedsParens appPrec p = cL loc (ParPat noExtField lp) - | otherwise = lp - -nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -nlParPat p = noLoc (ParPat noExtField p) - -------------------------------- --- These are the bits of syntax that contain rebindable names --- See RnEnv.lookupSyntaxName - -mkHsIntegral :: IntegralLit -> HsOverLit GhcPs -mkHsFractional :: FractionalLit -> HsOverLit GhcPs -mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs -mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> HsExpr GhcPs - -mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) - -> Pat GhcPs -mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs - -mkLastStmt :: Located (bodyR (GhcPass idR)) - -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) -mkBodyStmt :: Located (bodyR GhcPs) - -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) -mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR) - (Located (bodyR (GhcPass idR))) ~ NoExtField) - => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) - -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) -mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) - -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) - -emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR -emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR -emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR -mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR] - -> StmtLR (GhcPass idL) GhcPs bodyR - - -mkHsIntegral i = OverLit noExtField (HsIntegral i) noExpr -mkHsFractional f = OverLit noExtField (HsFractional f) noExpr -mkHsIsString src s = OverLit noExtField (HsIsString src s) noExpr - -mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts) -mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) - where - last_stmt = cL (getLoc expr) $ mkLastStmt expr - -mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) - -> HsExpr (GhcPass p) -mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b - -mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) - -> HsCmd (GhcPass p) -mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b - -mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr -mkNPlusKPat id lit - = NPlusKPat noExtField id lit (unLoc lit) noSyntaxExpr noSyntaxExpr - -mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> LHsExpr GhcPs - -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) - -emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt = TransStmt { trS_ext = noExtField - , trS_form = panic "emptyTransStmt: form" - , trS_stmts = [], trS_bndrs = [] - , trS_by = Nothing, trS_using = noLoc noExpr - , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr - , trS_fmap = noExpr } -mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } -mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } -mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } - -mkLastStmt body = LastStmt noExtField body False noSyntaxExpr -mkBodyStmt body - = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr -mkBindStmt pat body - = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr -mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr - -- don't use placeHolderTypeTc above, because that panics during zonking - -emptyRecStmt' :: forall idL idR body. - XRecStmt (GhcPass idL) (GhcPass idR) body - -> StmtLR (GhcPass idL) (GhcPass idR) body -emptyRecStmt' tyVal = - RecStmt - { recS_stmts = [], recS_later_ids = [] - , recS_rec_ids = [] - , recS_ret_fn = noSyntaxExpr - , recS_mfix_fn = noSyntaxExpr - , recS_bind_fn = noSyntaxExpr - , recS_ext = tyVal } - -unitRecStmtTc :: RecStmtTc -unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy - , recS_later_rets = [] - , recS_rec_rets = [] - , recS_ret_ty = unitTy } - -emptyRecStmt = emptyRecStmt' noExtField -emptyRecStmtName = emptyRecStmt' noExtField -emptyRecStmtId = emptyRecStmt' unitRecStmtTc - -- a panic might trigger during zonking -mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } - -------------------------------- ---- A useful function for building @OpApps@. The operator is always a --- variable, and we don't know the fixity yet. -mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLoc (HsVar noExtField (noLoc op))) e2 - -unqualSplice :: RdrName -unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) - -mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkUntypedSplice hasParen e = HsUntypedSplice noExtField hasParen unqualSplice e - -mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkTypedSplice hasParen e = HsTypedSplice noExtField hasParen unqualSplice e - -mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs -mkHsQuasiQuote quoter span quote - = HsQuasiQuote noExtField unqualSplice quoter span quote - -unqualQuasiQuote :: RdrName -unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) - -- A name (uniquified later) to - -- identify the quasi-quote - -mkHsString :: String -> HsLit (GhcPass p) -mkHsString s = HsString NoSourceText (mkFastString s) - -mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) -mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) - - -{- -************************************************************************ -* * - Constructing syntax with no location info -* * -************************************************************************ --} - -nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) -nlHsVar n = noLoc (HsVar noExtField (noLoc n)) - --- NB: Only for LHsExpr **Id** -nlHsDataCon :: DataCon -> LHsExpr GhcTc -nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con)) - -nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) -nlHsLit n = noLoc (HsLit noExtField n) - -nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLoc (HsLit noExtField (HsInt noExtField (mkIntegralLit n))) - -nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) -nlVarPat n = noLoc (VarPat noExtField (noLoc n)) - -nlLitPat :: HsLit GhcPs -> LPat GhcPs -nlLitPat l = noLoc (LitPat noExtField l) - -nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x)) - -nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] - -> LHsExpr (GhcPass id) -nlHsSyntaxApps (SyntaxExpr { syn_expr = fun - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) args - | [] <- arg_wraps -- in the noSyntaxExpr case - = ASSERT( isIdHsWrapper res_wrap ) - foldl' nlHsApp (noLoc fun) args - - | otherwise - = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" - mkLHsWrap arg_wraps args)) - -nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) -nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs - -nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) -nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExtField (noLoc f)) - (map ((HsVar noExtField) . noLoc) xs)) - where - mk f a = HsApp noExtField (noLoc f) (noLoc a) - -nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs -nlConVarPat con vars = nlConPat con (map nlVarPat vars) - -nlConVarPatName :: Name -> [Name] -> LPat GhcRn -nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) - -nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs -nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) - (InfixCon (parenthesizePat opPrec l) - (parenthesizePat opPrec r))) - -nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs -nlConPat con pats = - noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) - -nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn -nlConPatName con pats = - noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) - -nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p) -nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) - -nlWildConPat :: DataCon -> LPat GhcPs -nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (PrefixCon (replicate (dataConSourceArity con) - nlWildPat))) - -nlWildPat :: LPat GhcPs -nlWildPat = noLoc (WildPat noExtField ) -- Pre-typechecking - -nlWildPatName :: LPat GhcRn -nlWildPatName = noLoc (WildPat noExtField ) -- Pre-typechecking - -nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] - -> LHsExpr GhcPs -nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) - -nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) - -nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) - -> LHsExpr (GhcPass id) -nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] - -> LHsExpr GhcPs -nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs - -nlHsLam match = noLoc (HsLam noExtField (mkMatchGroup Generated [match])) -nlHsPar e = noLoc (HsPar noExtField e) - --- Note [Rebindable nlHsIf] --- nlHsIf should generate if-expressions which are NOT subject to --- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) -nlHsIf cond true false = noLoc (HsIf noExtField Nothing cond true false) - -nlHsCase expr matches - = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches)) -nlList exprs = noLoc (ExplicitList noExtField Nothing exprs) - -nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) -nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) - -nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t)) -nlHsTyVar x = noLoc (HsTyVar noExtField NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b) -nlHsParTy t = noLoc (HsParTy noExtField t) - -nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) -nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys - -nlHsAppKindTy :: - LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) -nlHsAppKindTy f k - = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k)) - -{- -Tuples. All these functions are *pre-typechecker* because they lack -types on the tuple. --} - -mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) --- Makes a pre-typechecker boxed tuple, deals with 1 case -mkLHsTupleExpr [e] = e -mkLHsTupleExpr es - = noLoc $ ExplicitTuple noExtField (map (noLoc . (Present noExtField)) es) Boxed - -mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) -mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) - -nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs -nlTuplePat pats box = noLoc (TuplePat noExtField pats box) - -missingTupArg :: HsTupArg GhcPs -missingTupArg = Missing noExtField - -mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn -mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed -mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed - --- The Big equivalents for the source tuple expressions -mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) -mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) - -mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) -mkBigLHsTup = mkChunkified mkLHsTupleExpr - --- The Big equivalents for the source tuple patterns -mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn -mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) - -mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn -mkBigLHsPatTup = mkChunkified mkLHsPatTup - --- $big_tuples --- #big_tuples# --- --- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but --- we might concievably want to build such a massive tuple as part of the --- output of a desugaring stage (notably that for list comprehensions). --- --- We call tuples above this size \"big tuples\", and emulate them by --- creating and pattern matching on >nested< tuples that are expressible --- by GHC. --- --- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) --- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any --- construction to be big. --- --- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' --- and 'mkTupleCase' functions to do all your work with tuples you should be --- fine, and not have to worry about the arity limitation at all. - --- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon -mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' - -> [a] -- ^ Possible \"big\" list of things to construct from - -> a -- ^ Constructed thing made possible by recursive decomposition -mkChunkified small_tuple as = mk_big_tuple (chunkify as) - where - -- Each sub-list is short enough to fit in a tuple - mk_big_tuple [as] = small_tuple as - mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) - -chunkify :: [a] -> [[a]] --- ^ Split a list into lists that are small enough to have a corresponding --- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' --- But there may be more than 'mAX_TUPLE_SIZE' sub-lists -chunkify xs - | n_xs <= mAX_TUPLE_SIZE = [xs] - | otherwise = split xs - where - n_xs = length xs - split [] = [] - split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) - -{- -************************************************************************ -* * - LHsSigType and LHsSigWcType -* * -********************************************************************* -} - -mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs -mkLHsSigType ty = mkHsImplicitBndrs ty - -mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs -mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty) - -mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a)) - -> [LSig GhcRn] - -> NameEnv a -mkHsSigEnv get_info sigs - = mkNameEnv (mk_pairs ordinary_sigs) - `extendNameEnvList` (mk_pairs gen_dm_sigs) - -- The subtlety is this: in a class decl with a - -- default-method signature as well as a method signature - -- we want the latter to win (#12533) - -- class C x where - -- op :: forall a . x a -> x a - -- default op :: forall b . x b -> x b - -- op x = ...(e :: b -> b)... - -- The scoped type variables of the 'default op', namely 'b', - -- scope over the code for op. The 'forall a' does not! - -- This applies both in the renamer and typechecker, both - -- of which use this function - where - (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs - is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True - is_gen_dm_sig _ = False - - mk_pairs :: [LSig GhcRn] -> [(Name, a)] - mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs - , (dL->L _ n) <- ns ] - -mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] --- Convert TypeSig to ClassOpSig --- The former is what is parsed, but the latter is --- what we need in class/instance declarations -mkClassOpSigs sigs - = map fiddle sigs - where - fiddle (dL->L loc (TypeSig _ nms ty)) - = cL loc (ClassOpSig noExtField False nms (dropWildCards ty)) - fiddle sig = sig - -typeToLHsType :: Type -> LHsType GhcPs --- ^ Converting a Type to an HsType RdrName --- This is needed to implement GeneralizedNewtypeDeriving. --- --- Note that we use 'getRdrName' extensively, which --- generates Exact RdrNames rather than strings. -typeToLHsType ty - = go ty - where - go :: Type -> LHsType GhcPs - go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res }) - = case af of - VisArg -> nlHsFunTy (go arg) (go res) - InvisArg | (theta, tau) <- tcSplitPhiTy ty - -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) - , hst_xqual = noExtField - , hst_body = go tau }) - - go ty@(ForAllTy (Bndr _ argf) _) - | (tvs, tau) <- tcSplitForAllTysSameVis argf ty - = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf - , hst_bndrs = map go_tv tvs - , hst_xforall = noExtField - , hst_body = go tau }) - go (TyVarTy tv) = nlHsTyVar (getRdrName tv) - go (LitTy (NumTyLit n)) - = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n) - go (LitTy (StrTyLit s)) - = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s) - go ty@(TyConApp tc args) - | tyConAppNeedsKindSig True tc (length args) - -- We must produce an explicit kind signature here to make certain - -- programs kind-check. See Note [Kind signatures in typeToLHsType]. - = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty)) - | otherwise = ty' - where - ty' :: LHsType GhcPs - ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args) - go ty@(AppTy {}) = go_app (go head) args (appTyArgFlags head args) - where - head :: Type - args :: [Type] - (head, args) = splitAppTys ty - go (CastTy ty _) = go ty - go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) - - -- Source-language types have _invisible_ kind arguments, - -- so we must remove them here (#8563) - - go_app :: LHsType GhcPs -- The type being applied - -> [Type] -- The argument types - -> [ArgFlag] -- The argument types' visibilities - -> LHsType GhcPs - go_app head args arg_flags = - foldl' (\f (arg, flag) -> - let arg' = go arg in - case flag of - Inferred -> f - Specified -> f `nlHsAppKindTy` arg' - Required -> f `nlHsAppTy` arg') - head (zip args arg_flags) - - go_tv :: TyVar -> LHsTyVarBndr GhcPs - go_tv tv = noLoc $ KindedTyVar noExtField (noLoc (getRdrName tv)) - (go (tyVarKind tv)) - -{- -Note [Kind signatures in typeToLHsType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are types that typeToLHsType can produce which require explicit kind -signatures in order to kind-check. Here is an example from #14579: - - -- type P :: forall {k} {t :: k}. Proxy t - type P = 'Proxy - - -- type Wat :: forall a. Proxy a -> * - newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) - deriving Eq - - -- type Wat2 :: forall {a}. Proxy a -> * - type Wat2 = Wat - - -- type Glurp :: * -> * - newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a)) - deriving Eq - -The derived Eq instance for Glurp (without any kind signatures) would be: - - instance Eq a => Eq (Glurp a) where - (==) = coerce @(Wat2 P -> Wat2 P -> Bool) - @(Glurp a -> Glurp a -> Bool) - (==) :: Glurp a -> Glurp a -> Bool - -(Where the visible type applications use types produced by typeToLHsType.) - -The type P (in Wat2 P) has an underspecified kind, so we must ensure that -typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish -this, whenever we see an application of a tycon to some arguments, we use -the tyConAppNeedsKindSig function to determine if it requires an explicit kind -signature to resolve some ambiguity. (See Note -Note [When does a tycon application need an explicit kind signature?] for a -more detailed explanation of how this works.) - -Note that we pass True to tyConAppNeedsKindSig since we are generated code with -visible kind applications, so even specified arguments count towards injective -positions in the kind of the tycon. --} - -{- ********************************************************************* -* * - --------- HsWrappers: type args, dict args, casts --------- -* * -********************************************************************* -} - -mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) - --- Avoid (HsWrap co (HsWrap co' _)). --- See Note [Detecting forced eta expansion] in DsExpr -mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) -mkHsWrap co_fn e | isIdHsWrapper co_fn = e -mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e -mkHsWrap co_fn e = HsWrap noExtField co_fn e - -mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) -mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e - -mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b - -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) -mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e - -mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) - -mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) -mkHsCmdWrap w cmd | isIdHsWrapper w = cmd - | otherwise = HsCmdWrap noExtField w cmd - -mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) -mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) - -mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) -mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat noExtField co_fn p ty - -mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) -mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat noExtField (mkWpCastN co) pat ty - -mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc -mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr - -{- -l -************************************************************************ -* * - Bindings; with a location at the top -* * -************************************************************************ --} - -mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] - -> HsBind GhcPs --- Not infix, with place holders for coercion and free vars -mkFunBind fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup Generated ms - , fun_co_fn = idHsWrapper - , fun_ext = noExtField - , fun_tick = [] } - -mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] - -> HsBind GhcRn --- In Name-land, with empty bind_fvs -mkTopFunBind origin fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup origin ms - , fun_co_fn = idHsWrapper - , fun_ext = emptyNameSet -- NB: closed - -- binding - , fun_tick = [] } - -mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs -mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs - -mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) -mkVarBind var rhs = cL (getLoc rhs) $ - VarBind { var_ext = noExtField, - var_id = var, var_rhs = rhs, var_inline = False } - -mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) - -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs -mkPatSynBind name details lpat dir = PatSynBind noExtField psb - where - psb = PSB{ psb_ext = noExtField - , psb_id = name - , psb_args = details - , psb_def = lpat - , psb_dir = dir } - --- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is --- considered infix. -isInfixFunBind :: HsBindLR id1 id2 -> Bool -isInfixFunBind (FunBind _ _ (MG _ matches _) _ _) - = any (isInfixMatch . unLoc) (unLoc matches) -isInfixFunBind _ = False - - ------------- -mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs] - -> LHsExpr GhcPs -> LHsBind GhcPs -mk_easy_FunBind loc fun pats expr - = cL loc $ mkFunBind (cL loc fun) - [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr - (noLoc emptyLocalBinds)] - --- | Make a prefix, non-strict function 'HsMatchContext' -mkPrefixFunRhs :: Located id -> HsMatchContext id -mkPrefixFunRhs n = FunRhs { mc_fun = n - , mc_fixity = Prefix - , mc_strictness = NoSrcStrict } - ------------- -mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) - -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) - -> Located (HsLocalBinds (GhcPass p)) - -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) -mkMatch ctxt pats expr lbinds - = noLoc (Match { m_ext = noExtField - , m_ctxt = ctxt - , m_pats = map paren pats - , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) - where - paren lp@(dL->L l p) - | patNeedsParens appPrec p = cL l (ParPat noExtField lp) - | otherwise = lp - -{- -************************************************************************ -* * - Collecting binders -* * -************************************************************************ - -Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. - -... -where - (x, y) = ... - f i j = ... - [a, b] = ... - -it should return [x, y, f, a, b] (remember, order important). - -Note [Collect binders only after renaming] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These functions should only be used on HsSyn *after* the renamer, -to return a [Name] or [Id]. Before renaming the record punning -and wild-card mechanism makes it hard to know what is bound. -So these functions should not be applied to (HsSyn RdrName) - -Note [Unlifted id check in isUnliftedHsBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function isUnliftedHsBind is used to complain if we make a top-level -binding for a variable of unlifted type. - -Such a binding is illegal if the top-level binding would be unlifted; -but also if the local letrec generated by desugaring AbsBinds would be. -E.g. - f :: Num a => (# a, a #) - g :: Num a => a -> a - f = ...g... - g = ...g... - -The top-level bindings for f,g are not unlifted (because of the Num a =>), -but the local, recursive, monomorphic bindings are: - - t = /\a \(d:Num a). - letrec fm :: (# a, a #) = ...g... - gm :: a -> a = ...f... - in (fm, gm) - -Here the binding for 'fm' is illegal. So generally we check the abe_mono types. - -BUT we have a special case when abs_sig is true; - see HsBinds Note [The abs_sig field of AbsBinds] --} - ------------------ Bindings -------------------------- - --- | Should we treat this as an unlifted bind? This will be true for any --- bind that binds an unlifted variable, but we must be careful around --- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage --- information, see Note [Strict binds check] is DsBinds. -isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds -isUnliftedHsBind bind - | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind - = if has_sig - then any (is_unlifted_id . abe_poly) exports - else any (is_unlifted_id . abe_mono) exports - -- If has_sig is True we wil never generate a binding for abe_mono, - -- so we don't need to worry about it being unlifted. The abe_poly - -- binding might not be: e.g. forall a. Num a => (# a, a #) - - | otherwise - = any is_unlifted_id (collectHsBindBinders bind) - where - is_unlifted_id id = isUnliftedType (idType id) - --- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? -isBangedHsBind :: HsBind GhcTc -> Bool -isBangedHsBind (AbsBinds { abs_binds = binds }) - = anyBag (isBangedHsBind . unLoc) binds -isBangedHsBind (FunBind {fun_matches = matches}) - | [dL->L _ match] <- unLoc $ mg_alts matches - , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match - = True -isBangedHsBind (PatBind {pat_lhs = pat}) - = isBangedLPat pat -isBangedHsBind _ - = False - -collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) - -> [IdP (GhcPass idL)] -collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds - -- No pattern synonyms here -collectLocalBinders (HsIPBinds {}) = [] -collectLocalBinders (EmptyLocalBinds _) = [] -collectLocalBinders (XHsLocalBindsLR _) = [] - -collectHsIdBinders, collectHsValBinders - :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] --- Collect Id binders only, or Ids + pattern synonyms, respectively -collectHsIdBinders = collect_hs_val_binders True -collectHsValBinders = collect_hs_val_binders False - -collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=> - HsBindLR p idR -> [IdP p] --- Collect both Ids and pattern-synonym binders -collectHsBindBinders b = collect_bind False b [] - -collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] -collectHsBindsBinders binds = collect_binds False binds [] - -collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)] --- Same as collectHsBindsBinders, but works over a list of bindings -collectHsBindListBinders = foldr (collect_bind False . unLoc) [] - -collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) - -> [IdP (GhcPass idL)] -collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] -collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) - = collect_out_binds ps binds - -collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] -> - [IdP (GhcPass p)] -collect_out_binds ps = foldr (collect_binds ps . snd) [] - -collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> - [IdP (GhcPass p)] -> [IdP (GhcPass p)] --- Collect Ids, or Ids + pattern synonyms, depending on boolean flag -collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds - -collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] -collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc -collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc -collect_bind _ (VarBind { var_id = f }) acc = f : acc -collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc - -- I don't think we want the binders from the abe_binds - - -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc - | omitPatSyn = acc - | otherwise = ps : acc -collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc -collect_bind _ (XHsBindsLR _) acc = acc - -collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)] --- Used exclusively for the bindings of an instance decl which are all FunBinds -collectMethodBinders binds = foldr (get . unLoc) [] binds - where - get (FunBind { fun_id = f }) fs = f : fs - get _ fs = fs - -- Someone else complains about non-FunBinds - ------------------ Statements -------------------------- -collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body] - -> [IdP (GhcPass idL)] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body] - -> [IdP (GhcPass idL)] -collectStmtsBinders = concatMap collectStmtBinders - -collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body - -> [IdP (GhcPass idL)] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body - -> [IdP (GhcPass idL)] - -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat -collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds) -collectStmtBinders (BodyStmt {}) = [] -collectStmtBinders (LastStmt {}) = [] -collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders - $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] -collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss -collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args - where - collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat - collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat - collectArgBinders _ = [] -collectStmtBinders (XStmtLR nec) = noExtCon nec - - ------------------ Patterns -------------------------- -collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)] -collectPatBinders pat = collect_lpat pat [] - -collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] -collectPatsBinders pats = foldr collect_lpat [] pats - -------------- -collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => - LPat p -> [IdP p] -> [IdP p] -collect_lpat p bndrs - = go (unLoc p) - where - go (VarPat _ var) = unLoc var : bndrs - go (WildPat _) = bndrs - go (LazyPat _ pat) = collect_lpat pat bndrs - go (BangPat _ pat) = collect_lpat pat bndrs - go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs - go (ViewPat _ _ pat) = collect_lpat pat bndrs - go (ParPat _ pat) = collect_lpat pat bndrs - - go (ListPat _ pats) = foldr collect_lpat bndrs pats - go (TuplePat _ pats _) = foldr collect_lpat bndrs pats - go (SumPat _ pat _ _) = collect_lpat pat bndrs - - go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) - go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) - -- See Note [Dictionary binders in ConPatOut] - go (LitPat _ _) = bndrs - go (NPat {}) = bndrs - go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs - - go (SigPat _ pat _) = collect_lpat pat bndrs - - go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) - = go pat - go (SplicePat _ _) = bndrs - go (CoPat _ _ pat _) = go pat - go (XPat {}) = bndrs - -{- -Note [Dictionary binders in ConPatOut] See also same Note in DsArrows -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do *not* gather (a) dictionary and (b) dictionary bindings as binders -of a ConPatOut pattern. For most calls it doesn't matter, because -it's pre-typechecker and there are no ConPatOuts. But it does matter -more in the desugarer; for example, DsUtils.mkSelectorBinds uses -collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., -we want to generate bindings for x,y but not for dictionaries bound by -C. (The type checker ensures they would not be used.) - -Desugaring of arrow case expressions needs these bindings (see DsArrows -and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its -own pat-binder-collector: - -Here's the problem. Consider - -data T a where - C :: Num a => a -> Int -> T a - -f ~(C (n+1) m) = (n,m) - -Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), -and *also* uses that dictionary to match the (n+1) pattern. Yet, the -variables bound by the lazy pattern are n,m, *not* the dictionary d. -So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. --} - -hsGroupBinders :: HsGroup GhcRn -> [Name] -hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, - hs_fords = foreign_decls }) - = collectHsValBinders val_decls - ++ hsTyClForeignBinders tycl_decls foreign_decls -hsGroupBinders (XHsGroup nec) = noExtCon nec - -hsTyClForeignBinders :: [TyClGroup GhcRn] - -> [LForeignDecl GhcRn] - -> [Name] --- We need to look at instance declarations too, --- because their associated types may bind data constructors -hsTyClForeignBinders tycl_decls foreign_decls - = map unLoc (hsForeignDeclsBinders foreign_decls) - ++ getSelectorNames - (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls - `mappend` - foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) - where - getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] - getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs - -------------------- -hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p)) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) --- ^ Returns all the /binding/ names of the decl. The first one is --- guaranteed to be the name of the decl. The first component --- represents all binding names except record fields; the second --- represents field occurrences. For record fields mentioned in --- multiple constructors, the SrcLoc will be from the first occurrence. --- --- Each returned (Located name) has a SrcSpan for the /whole/ declaration. --- See Note [SrcSpan for binders] - -hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl - { fdLName = (dL->L _ name) } })) - = ([cL loc name], []) -hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec })) - = noExtCon nec -hsLTyClDeclBinders (dL->L loc (SynDecl - { tcdLName = (dL->L _ name) })) - = ([cL loc name], []) -hsLTyClDeclBinders (dL->L loc (ClassDecl - { tcdLName = (dL->L _ cls_name) - , tcdSigs = sigs - , tcdATs = ats })) - = (cL loc cls_name : - [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl - { fdLName = L _ fam_name })) <- ats ] - ++ - [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs - , (dL->L _ mem_name) <- ns ] - , []) -hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) - , tcdDataDefn = defn })) - = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn -hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec -hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" - -- due to #15884 - - -------------------- -hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] --- See Note [SrcSpan for binders] -hsForeignDeclsBinders foreign_decls - = [ cL decl_loc n - | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) })) - <- foreign_decls] - - -------------------- -hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] --- Collects record pattern-synonym selectors only; the pattern synonym --- names are collected by collectHsValBinders. -hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" -hsPatSynSelectors (XValBindsLR (NValBinds binds _)) - = foldr addPatSynSelector [] . unionManyBags $ map snd binds - -addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] -addPatSynSelector bind sels - | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind - = map (unLoc . recordPatSynSelectorId) as ++ sels - | otherwise = sels - -getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] -getPatSynBinds binds - = [ psb | (_, lbinds) <- binds - , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ] - -------------------- -hsLInstDeclBinders :: LInstDecl (GhcPass p) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -hsLInstDeclBinders (dL->L _ (ClsInstD - { cid_inst = ClsInstDecl - { cid_datafam_insts = dfis }})) - = foldMap (hsDataFamInstBinders . unLoc) dfis -hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) - = hsDataFamInstBinders fi -hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty -hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec))) - = noExtCon nec -hsLInstDeclBinders (dL->L _ (XInstDecl nec)) - = noExtCon nec -hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" - -- due to #15884 - -------------------- --- the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl (GhcPass p) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = - FamEqn { feqn_rhs = defn }}}) - = hsDataDefnBinders defn - -- There can't be repeated symbols because only data instances have binders -hsDataFamInstBinders (DataFamInstDecl - { dfid_eqn = HsIB { hsib_body = XFamEqn nec}}) - = noExtCon nec -hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec)) - = noExtCon nec - -------------------- --- the SrcLoc returned are for the whole declarations, not just the names -hsDataDefnBinders :: HsDataDefn (GhcPass p) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -hsDataDefnBinders (HsDataDefn { dd_cons = cons }) - = hsConDeclsBinders cons - -- See Note [Binders in family instances] -hsDataDefnBinders (XHsDataDefn nec) = noExtCon nec - -------------------- -type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] - -- Filters out ones that have already been seen - -hsConDeclsBinders :: [LConDecl (GhcPass p)] - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) - -- See hsLTyClDeclBinders for what this does - -- The function is boringly complicated because of the records - -- And since we only have equality, we have to be a little careful -hsConDeclsBinders cons - = go id cons - where - go :: Seen p -> [LConDecl (GhcPass p)] - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) - go _ [] = ([], []) - go remSeen (r:rs) - -- Don't re-mangle the location of field names, because we don't - -- have a record of the full location of the field declaration anyway - = let loc = getLoc r - in case unLoc r of - -- remove only the first occurrence of any seen field in order to - -- avoid circumventing detection of duplicate fields (#9156) - ConDeclGADT { con_names = names, con_args = args } - -> (map (cL loc . unLoc) names ++ ns, flds ++ fs) - where - (remSeen', flds) = get_flds remSeen args - (ns, fs) = go remSeen' rs - - ConDeclH98 { con_name = name, con_args = args } - -> ([cL loc (unLoc name)] ++ ns, flds ++ fs) - where - (remSeen', flds) = get_flds remSeen args - (ns, fs) = go remSeen' rs - - XConDecl nec -> noExtCon nec - - get_flds :: Seen p -> HsConDeclDetails (GhcPass p) - -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds remSeen (RecCon flds) - = (remSeen', fld_names) - where - fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) - remSeen' = foldr (.) remSeen - [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v - | v <- fld_names] - get_flds remSeen _ - = (remSeen, []) - -{- - -Note [SrcSpan for binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When extracting the (Located RdrNme) for a binder, at least for the -main name (the TyCon of a type declaration etc), we want to give it -the @SrcSpan@ of the whole /declaration/, not just the name itself -(which is how it appears in the syntax tree). This SrcSpan (for the -entire declaration) is used as the SrcSpan for the Name that is -finally produced, and hence for error messages. (See #8607.) - -Note [Binders in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type or data family instance declaration, the type -constructor is an *occurrence* not a binding site - type instance T Int = Int -> Int -- No binders - data instance S Bool = S1 | S2 -- Binders are S1,S2 - - -************************************************************************ -* * - Collecting binders the user did not write -* * -************************************************************************ - -The job of this family of functions is to run through binding sites and find the set of all Names -that were defined "implicitly", without being explicitly written by the user. - -The main purpose is to find names introduced by record wildcards so that we can avoid -warning the user when they don't use those names (#4404) - -Since the addition of -Wunused-record-wildcards, this function returns a pair -of [(SrcSpan, [Name])]. Each element of the list is one set of implicit -binders, the first component of the tuple is the document describes the possible -fix to the problem (by removing the ..). - -This means there is some unfortunate coupling between this function and where it -is used but it's only used for one specific purpose in one place so it seemed -easier. --} - -lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] - -> [(SrcSpan, [Name])] -lStmtsImplicits = hs_lstmts - where - hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] - -> [(SrcSpan, [Name])] - hs_lstmts = concatMap (hs_stmt . unLoc) - - hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) - -> [(SrcSpan, [Name])] - hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat - hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args - where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat - do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts - do_arg (_, XApplicativeArg nec) = noExtCon nec - hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) - hs_stmt (BodyStmt {}) = [] - hs_stmt (LastStmt {}) = [] - hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs - , s <- ss] - hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts - hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss - hs_stmt (XStmtLR nec) = noExtCon nec - - hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds - hs_local_binds (HsIPBinds {}) = [] - hs_local_binds (EmptyLocalBinds _) = [] - hs_local_binds (XHsLocalBindsLR _) = [] - -hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])] -hsValBindsImplicits (XValBindsLR (NValBinds binds _)) - = concatMap (lhsBindsImplicits . snd) binds -hsValBindsImplicits (ValBinds _ binds _) - = lhsBindsImplicits binds - -lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])] -lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) [] - where - lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat - lhs_bind _ = [] - -lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])] -lPatImplicits = hs_lpat - where - hs_lpat lpat = hs_pat (unLoc lpat) - - hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) [] - - hs_pat (LazyPat _ pat) = hs_lpat pat - hs_pat (BangPat _ pat) = hs_lpat pat - hs_pat (AsPat _ _ pat) = hs_lpat pat - hs_pat (ViewPat _ _ pat) = hs_lpat pat - hs_pat (ParPat _ pat) = hs_lpat pat - hs_pat (ListPat _ pats) = hs_lpats pats - hs_pat (TuplePat _ pats _) = hs_lpats pats - - hs_pat (SigPat _ pat _) = hs_lpat pat - hs_pat (CoPat _ _ pat _) = hs_pat pat - - hs_pat (ConPatIn n ps) = details n ps - hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps - - hs_pat _ = [] - - details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] - details _ (PrefixCon ps) = hs_lpats ps - details n (RecCon fs) = - [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] - ++ hs_lpats explicit_pats - - where implicit_pats = map (hsRecFieldArg . unLoc) implicit - explicit_pats = map (hsRecFieldArg . unLoc) explicit - - - (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld - | (i, fld) <- [0..] `zip` rec_flds fs - , let pat_explicit = - maybe True ((i<) . unLoc) - (rec_dotdot fs)] - err_loc = maybe (getLoc n) getLoc (rec_dotdot fs) - - details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs deleted file mode 100644 index 244243a82f..0000000000 --- a/compiler/hsSyn/PlaceHolder.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} - -module PlaceHolder where - -import Name -import NameSet -import RdrName -import Var - - - -{- -%************************************************************************ -%* * -\subsection{Annotating the syntax} -%* * -%************************************************************************ --} - --- NB: These are intentionally open, allowing API consumers (like Haddock) --- to declare new instances - -placeHolderNamesTc :: NameSet -placeHolderNamesTc = emptyNameSet - -{- -TODO:AZ: remove this, and check if we still need all the UndecidableInstances - -Note [Pass sensitive types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the same AST types are re-used through parsing,renaming and type -checking there are naturally some places in the AST that do not have -any meaningful value prior to the pass they are assigned a value. - -Historically these have been filled in with place holder values of the form - - panic "error message" - -This has meant the AST is difficult to traverse using standard generic -programming techniques. The problem is addressed by introducing -pass-specific data types, implemented as a pair of open type families, -one for PostTc and one for PostRn. These are then explicitly populated -with a PlaceHolder value when they do not yet have meaning. - -In terms of actual usage, we have the following - - PostTc id Kind - PostTc id Type - - PostRn id Fixity - PostRn id NameSet - -TcId and Var are synonyms for Id - -Unfortunately the type checker termination checking conditions fail for the -DataId constraint type based on this, so even though it is safe the -UndecidableInstances pragma is required where this is used. --} - - --- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', --- for printing messages related to a 'Match' -type family NameOrRdrName id where - NameOrRdrName Id = Name - NameOrRdrName Name = Name - NameOrRdrName RdrName = RdrName diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index e3be840006..7e555ed45c 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -82,7 +82,7 @@ import TcType import InstEnv import FamInstEnv import TcRnMonad -import HsSyn +import GHC.Hs import HscTypes import Finder import DynFlags diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 87f0d12667..a66daa220e 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -227,7 +227,7 @@ module GHC ( TyThing(..), -- ** Syntax - module HsSyn, -- ToDo: remove extraneous bits + module GHC.Hs, -- ToDo: remove extraneous bits -- ** Fixities FixityDirection(..), @@ -314,7 +314,7 @@ import TcRnTypes import Packages import NameSet import RdrName -import HsSyn +import GHC.Hs import Type hiding( typeKind ) import TcType import Id diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs index 56492377d8..351f0b268a 100644 --- a/compiler/main/GhcPlugins.hs +++ b/compiler/main/GhcPlugins.hs @@ -90,7 +90,7 @@ import Data.Maybe import IfaceEnv ( lookupOrigIO ) import GhcPrelude import MonadUtils ( mapMaybeM ) -import Convert ( thRdrNameGuesses ) +import GHC.ThToHs ( thRdrNameGuesses ) import TcEnv ( lookupGlobal ) import qualified Language.Haskell.TH as TH diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 0d7e6fd702..d534fab1d5 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -26,7 +26,7 @@ import HscTypes import Parser ( parseHeader ) import Lexer import FastString -import HsSyn +import GHC.Hs import Module import PrelNames import StringBuffer diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index f9d420ab61..a562b3e33f 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -28,9 +28,9 @@ import GhcPrelude import DynFlags import PipelineMonad import HscTypes -import HsDecls -import HsBinds -import HsExpr +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr import OrdList import TcRnTypes import Bag @@ -43,7 +43,7 @@ import SrcLoc import Type import System.Process import BasicTypes -import HsExtension +import GHC.Hs.Extension import Data.Maybe diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index f2fc6e98d2..a9fe3ffe18 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -104,8 +104,8 @@ import Control.Concurrent import Module import Packages import RdrName -import HsSyn -import HsDumpAst +import GHC.Hs +import GHC.Hs.Dump import CoreSyn import StringBuffer import Parser diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index df77ae41a4..27f192227f 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -13,7 +13,7 @@ module HscStats ( ppSourceStats ) where import GhcPrelude import Bag -import HsSyn +import GHC.Hs import Outputable import SrcLoc import Util diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index a9e9bcb363..274b777eec 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -155,7 +155,7 @@ import GHCi.RemoteTypes import GHC.ForeignSrcLang import UniqFM -import HsSyn +import GHC.Hs import RdrName import Avail import Module diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 88c8ecc7df..e7f3947210 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -53,7 +53,7 @@ import GHCi.Message import GHCi.RemoteTypes import GhcMonad import HscMain -import HsSyn +import GHC.Hs import HscTypes import InstEnv import IfaceEnv ( newInteractiveBinder ) diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs index c787960dd6..66eebb9f63 100644 --- a/compiler/main/Plugins.hs +++ b/compiler/main/Plugins.hs @@ -53,7 +53,7 @@ import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM ) import qualified TcRnTypes import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) import TcHoleFitTypes ( HoleFitPluginR ) -import HsSyn +import GHC.Hs import DynFlags import HscTypes import GhcMonad diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs index 7969f6e1a2..d1d41a3d29 100644 --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -3,7 +3,7 @@ module HaddockUtils where import GhcPrelude -import HsSyn +import GHC.Hs import SrcLoc import Control.Monad diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 5f79879789..bc4b7b1a74 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -44,7 +44,7 @@ import Control.Monad ( mplus ) import Control.Applicative ((<$)) -- compiler/hsSyn -import HsSyn +import GHC.Hs -- compiler/main import HscTypes ( IsBootInterface, WarningTxt(..) ) @@ -3416,7 +3416,7 @@ qconop :: { Located RdrName } -- Type constructors --- See Note [Unit tuples] in HsTypes for the distinction +-- See Note [Unit tuples] in GHC.Hs.Types for the distinction -- between gtycon and ntgtycon gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples : ntgtycon { $1 } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index a574fbe338..538c20cc8a 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -103,7 +103,7 @@ module RdrHsSyn ( ) where import GhcPrelude -import HsSyn -- Lots of it +import GHC.Hs -- Lots of it import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) import DataCon ( DataCon, dataConTyCon ) import ConLike ( ConLike(..) ) @@ -157,7 +157,7 @@ import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) -- Similarly for mkConDecl, mkClassOpSig and default-method names. --- *** See Note [The Naming story] in HsDecls **** +-- *** See Note [The Naming story] in GHC.Hs.Decls **** mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) mkTyClD (dL->L loc d) = cL loc (TyClD noExtField d) @@ -670,7 +670,7 @@ mkGadtDecl names ty (args, res_ty) = split_tau tau - -- See Note [GADT abstract syntax] in HsDecls + -- See Note [GADT abstract syntax] in GHC.Hs.Decls split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) = (RecCon (cL loc rf), res_ty) split_tau tau @@ -932,7 +932,7 @@ checkTyClHdr is_cls ty arity = length ts tup_name | is_cls = cTupleTyConName arity | otherwise = getName (tupleTyCon Boxed arity) - -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) + -- See Note [Unit tuples] in GHC.Hs.Types (TODO: is this still relevant?) go l _ _ _ _ = addFatalError l (text "Malformed head of type or class declaration:" <+> ppr ty) @@ -1188,7 +1188,7 @@ checkFunBind strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs --- Like HsUtils.mkFunBind, but we need to be able to set the fixity too +-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms = FunBind { fun_ext = noExtField, fun_id = fn, @@ -2290,8 +2290,8 @@ rule, so this approach scales well to large parser productions. {- Note [Resolving parsing ambiguities: non-taken alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Alternative I, extra constructors in HsExpr -------------------------------------------- +Alternative I, extra constructors in GHC.Hs.Expr +------------------------------------------------ We could add extra constructors to HsExpr to represent command-specific and pattern-specific syntactic constructs. Under this scheme, we parse patterns and commands as expressions and rejig later. This is what GHC used to do, and @@ -2326,15 +2326,15 @@ There are several issues with this: (f ! a b) ! c = ... -Alternative II, extra constructors in HsExpr for GhcPs ------------------------------------------------------- +Alternative II, extra constructors in GHC.Hs.Expr for GhcPs +----------------------------------------------------------- We could address some of the problems with Alternative I by using Trees That Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to the output of parsing, not to its intermediate results, so we wouldn't want them there either. -Alternative III, extra constructors in HsExpr for GhcPrePs ----------------------------------------------------------- +Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs +--------------------------------------------------------------- We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. Unfortunately, creating a new pass would significantly bloat conversion code and slow down the compiler by adding another linear-time pass over the entire diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 5bb76f8f0d..811a81bdb1 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -30,7 +30,7 @@ import GhcPrelude import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) -import HsSyn +import GHC.Hs import TcRnMonad import RnTypes import RnPat @@ -248,7 +248,7 @@ rnLocalValBindsLHS fix_env binds -- Check for duplicates and shadowing -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in HsUtils + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils -- We need to check for dups here because we -- don't don't bind all of the variables from the ValBinds at once diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 91cf8f22f4..d9dbbee891 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -48,7 +48,7 @@ import GhcPrelude import LoadIface ( loadInterfaceForName, loadSrcInterface_maybe ) import IfaceEnv -import HsSyn +import GHC.Hs import RdrName import HscTypes import TcEnv diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index eadb4bca03..6485c004a6 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -26,7 +26,7 @@ import GhcPrelude import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, rnMatchGroup, rnGRHS, makeMiniFixityEnv) -import HsSyn +import GHC.Hs import TcEnv ( isBrackStage ) import TcRnMonad import Module ( getModule ) @@ -916,7 +916,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4 `plusFV` fvs5 bndr_map = used_bndrs `zip` used_bndrs - -- See Note [TransStmt binder map] in HsExpr + -- See Note [TransStmt binder map] in GHC.Hs.Expr ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map) ; return (([(L loc (TransStmt { trS_ext = noExtField diff --git a/compiler/rename/RnExpr.hs-boot b/compiler/rename/RnExpr.hs-boot index b325eeb6f0..8a9c7818a1 100644 --- a/compiler/rename/RnExpr.hs-boot +++ b/compiler/rename/RnExpr.hs-boot @@ -1,6 +1,6 @@ module RnExpr where import Name -import HsSyn +import GHC.Hs import NameSet ( FreeVars ) import TcRnTypes import SrcLoc ( Located ) diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs index 665d87747b..198a0441e5 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -14,7 +14,7 @@ module RnFixity ( MiniFixityEnv, import GhcPrelude import LoadIface -import HsSyn +import GHC.Hs import RdrName import HscTypes import TcRnMonad diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs index 348f87fca5..deaedb8bca 100644 --- a/compiler/rename/RnHsDoc.hs +++ b/compiler/rename/RnHsDoc.hs @@ -5,7 +5,7 @@ module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where import GhcPrelude import TcRnTypes -import HsSyn +import GHC.Hs import SrcLoc diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 5bfc1a37d8..738f4c6ab5 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -32,7 +32,7 @@ module RnNames ( import GhcPrelude import DynFlags -import HsSyn +import GHC.Hs import TcEnv import RnEnv import RnFixity @@ -607,7 +607,7 @@ extendGlobalRdrEnvRn avails new_fixities getLocalDeclBindersd@ returns the names for an HsDecl It's used for source code. - *** See Note [The Naming story] in HsDecls **** + *** See Note [The Naming story] in GHC.Hs.Decls **** * * ********************************************************************* -} diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 150b1cd23f..61cdc140bf 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -48,7 +48,7 @@ import {-# SOURCE #-} RnSplice ( rnSplicePat ) #include "HsVersions.h" -import HsSyn +import GHC.Hs import TcRnMonad import TcHsSyn ( hsOverLitName ) import RnEnv @@ -319,7 +319,7 @@ rnPats ctxt pats thing_inside ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in HsUtils + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils -- Because we don't bind the vars all at once, we can't -- check incrementally for duplicates; -- Nor can we check incrementally for shadowing, else we'll @@ -642,7 +642,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -- due to #15884 - rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in HsPat + rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) -> [LHsRecField GhcRn arg] -- Explicit fields diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 79280ee43f..229c66fda4 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -21,7 +21,7 @@ import GhcPrelude import {-# SOURCE #-} RnExpr( rnLExpr ) import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls ) -import HsSyn +import GHC.Hs import FieldLabel import RdrName import RnTypes @@ -1617,7 +1617,7 @@ dataDeclHasCUSK tyvars new_or_data no_rhs_kvs has_kind_sig = do | NewType <- new_or_data = unlifted_newtypes && not has_kind_sig | otherwise = False - -- See Note [CUSKs: complete user-supplied kind signatures] in HsDecls + -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls ; cusks_enabled <- xoptM LangExt.CUSKs ; return $ cusks_enabled && hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype @@ -2073,7 +2073,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names RecCon {} -> (new_args, new_res_ty) PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty -> ASSERT( null as ) - -- See Note [GADT abstract syntax] in HsDecls + -- See Note [GADT abstract syntax] in GHC.Hs.Decls (PrefixCon arg_tys, final_res_ty) new_qtvs = HsQTvs { hsq_ext = implicit_tkvs diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 9c3e317958..3e6d64751d 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -16,7 +16,7 @@ import GhcPrelude import Name import NameSet -import HsSyn +import GHC.Hs import RdrName import TcRnMonad diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot index 7844acd2c9..cd6021027e 100644 --- a/compiler/rename/RnSplice.hs-boot +++ b/compiler/rename/RnSplice.hs-boot @@ -1,7 +1,7 @@ module RnSplice where import GhcPrelude -import HsSyn +import GHC.Hs import TcRnMonad import NameSet diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 80b03d3f25..e982e72f82 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -38,7 +38,7 @@ import GhcPrelude import {-# SOURCE #-} RnSplice( rnSpliceType ) import DynFlags -import HsSyn +import GHC.Hs import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn @@ -280,7 +280,7 @@ partition_nwcs free_vars ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Identifiers starting with an underscore are always parsed as type variables. It is only here in the renamer that we give the special treatment. -See Note [The wildcard story for types] in HsTypes. +See Note [The wildcard story for types] in GHC.Hs.Types. It's easy! When we collect the implicitly bound type variables, ready to bring them into scope, and NamedWildCards is on, we partition the @@ -803,7 +803,7 @@ bindHsQTyVars :: forall a b. -- The Bool is True <=> all kind variables used in the -- kind signature are bound on the left. Reason: -- the last clause of Note [CUSKs: Complete user-supplied - -- kind signatures] in HsDecls + -- kind signatures] in GHC.Hs.Decls -> RnM (b, FreeVars) -- See Note [bindHsQTyVars examples] diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index a4715a23f6..6678ad6dbf 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -33,7 +33,7 @@ where import GhcPrelude -import HsSyn +import GHC.Hs import RdrName import HscTypes import TcEnv diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index a00e8ad2ba..052ef2b6c7 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -435,7 +435,7 @@ data StgPass | LiftLams | CodeGen --- | Like 'HsExtension.NoExtField', but with an 'Outputable' instance that +-- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. data NoExtFieldSilent = NoExtFieldSilent deriving (Data, Eq, Ord) @@ -447,8 +447,8 @@ instance Outputable NoExtFieldSilent where -- not appear in pretty-printed output at all. noExtFieldSilent :: NoExtFieldSilent noExtFieldSilent = NoExtFieldSilent --- TODO: Maybe move this to HsExtension? I'm not sure about the implications --- on build time... +-- TODO: Maybe move this to GHC.Hs.Extension? I'm not sure about the +-- implications on build time... -- TODO: Do we really want to the extension point type families to have a closed -- domain? diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 1ec85b22d1..8e180b4cf4 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -39,7 +39,7 @@ import {-# SOURCE #-} TcUnify( unifyType, unifyKind ) import BasicTypes ( IntegralLit(..), SourceText(..) ) import FastString -import HsSyn +import GHC.Hs import TcHsSyn import TcRnMonad import TcEnv @@ -608,7 +608,7 @@ tcSyntaxName :: CtOrigin -> TcM (Name, HsExpr GhcTcId) -- ^ (Standard name, suitable expression) -- USED ONLY FOR CmdTop (sigh) *** --- See Note [CmdSyntaxTable] in HsExpr +-- See Note [CmdSyntaxTable] in GHC.Hs.Expr tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) | std_nm == user_nm diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 00c1958106..b3736ed7bb 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -18,7 +18,7 @@ import Module import DynFlags import Control.Monad ( when ) -import HsSyn +import GHC.Hs import Name import Annotations import TcRnMonad diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index c5e3ca99b2..d9c2136aca 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -14,7 +14,7 @@ import GhcPrelude import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) -import HsSyn +import GHC.Hs import TcMatches import TcHsSyn( hsLPatType ) import TcType @@ -388,7 +388,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names -- NB: The rec_ids for the recursive things -- already scope over this part. This binding may shadow -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in HsExpr) + -- (see note [RecStmt] in GHC.Hs.Expr) ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index 7fffcd1d18..1e9a1ea691 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -23,7 +23,7 @@ import BasicTypes (defaultFixity) import Packages import TcRnExports import DynFlags -import HsSyn +import GHC.Hs import RdrName import TcRnMonad import TcTyDecls diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index fcf871f75f..8f14abe32f 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -25,7 +25,7 @@ import CoreSyn (Tickish (..)) import CostCentre (mkUserCC, CCFlavour(DeclCC)) import DynFlags import FastString -import HsSyn +import GHC.Hs import HscTypes( isHsBootOrSig ) import TcSigs import TcRnMonad diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 31c9ad9a89..e779c6794f 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -36,7 +36,7 @@ import Outputable import DynFlags( DynFlags ) import NameSet import RdrName -import HsTypes( HsIPName(..) ) +import GHC.Hs.Types( HsIPName(..) ) import Pair import Util diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 0239793a51..6f2ef4c292 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -22,7 +22,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, import GhcPrelude -import HsSyn +import GHC.Hs import TcEnv import TcSigs import TcEvidence ( idHsWrapper ) diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs index 926eca1ac0..a204486147 100644 --- a/compiler/typecheck/TcDefaults.hs +++ b/compiler/typecheck/TcDefaults.hs @@ -10,7 +10,7 @@ module TcDefaults ( tcDefaults ) where import GhcPrelude -import HsSyn +import GHC.Hs import Class import TcRnMonad import TcEnv diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 0863e22cb9..0b78b8e2ed 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -15,7 +15,7 @@ module TcDeriv ( tcDeriving, DerivInfo(..) ) where import GhcPrelude -import HsSyn +import GHC.Hs import DynFlags import TcRnMonad diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs index e7c2451246..ae191f937b 100644 --- a/compiler/typecheck/TcDerivUtils.hs +++ b/compiler/typecheck/TcDerivUtils.hs @@ -32,7 +32,7 @@ import DataCon import DynFlags import ErrUtils import HscTypes (lookupFixity, mi_fix) -import HsSyn +import GHC.Hs import Inst import InstEnv import LoadIface (loadInterfaceForName) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 0ec0601521..3cc1994f5b 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an -- orphan {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] - -- in module PlaceHolder + -- in module GHC.Hs.PlaceHolder {-# LANGUAGE TypeFamilies #-} module TcEnv( @@ -71,7 +71,7 @@ module TcEnv( import GhcPrelude -import HsSyn +import GHC.Hs import IfaceEnv import TcRnMonad import TcMType diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 02b888703d..832f859c8a 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -33,8 +33,8 @@ import Class import DataCon import TcEvidence import TcEvTerm -import HsExpr ( UnboundVar(..) ) -import HsBinds ( PatSynBind(..) ) +import GHC.Hs.Expr ( UnboundVar(..) ) +import GHC.Hs.Binds ( PatSynBind(..) ) import Name import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv , mkRdrUnqual, isLocalGRE, greSrcSpan ) diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 1387e89089..c195576c39 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -24,7 +24,7 @@ import GhcPrelude import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) import THNames( liftStringName, liftName ) -import HsSyn +import GHC.Hs import TcHsSyn import TcRnMonad import TcUnify @@ -1088,7 +1088,7 @@ arithSeqEltType (Just fl) res_ty ************************************************************************ -} --- HsArg is defined in HsTypes.hs +-- HsArg is defined in GHC.Hs.Types wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn) => LHsExpr (GhcPass id) @@ -2237,7 +2237,7 @@ particular update is sufficiently obvious for the signature to be omitted. Moreover, this might change the behaviour of typechecker in non-obvious ways. -See also Note [HsRecField and HsRecUpdField] in HsPat. +See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat. -} -- Given a RdrName that refers to multiple record fields, and the type diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot index bb6b5d181c..25650e34fc 100644 --- a/compiler/typecheck/TcExpr.hs-boot +++ b/compiler/typecheck/TcExpr.hs-boot @@ -1,9 +1,9 @@ module TcExpr where import Name -import HsSyn ( HsExpr, LHsExpr, SyntaxExpr ) +import GHC.Hs ( HsExpr, LHsExpr, SyntaxExpr ) import TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import TcRnTypes( TcM, CtOrigin ) -import HsExtension ( GhcRn, GhcTcId ) +import GHC.Hs.Extension ( GhcRn, GhcTcId ) tcPolyExpr :: LHsExpr GhcRn diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index ace0cddb66..3684061642 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -35,7 +35,7 @@ module TcForeign import GhcPrelude -import HsSyn +import GHC.Hs import TcRnMonad import TcHsType diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 4a7032cedf..a7f8f79530 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -40,7 +40,7 @@ module TcGenDeriv ( import GhcPrelude import TcRnMonad -import HsSyn +import GHC.Hs import RdrName import BasicTypes import DataCon diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index c2cdef412a..19cd9d903a 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -23,7 +23,7 @@ import GhcPrelude import Bag import DataCon import FastString -import HsSyn +import GHC.Hs import Panic import PrelNames import RdrName diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index ecf0d8b76d..087bd938f0 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -16,7 +16,7 @@ module TcGenGenerics (canDoGenerics, canDoGenerics1, import GhcPrelude -import HsSyn +import GHC.Hs import Type import TcType import TcGenDeriv diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs index 8c9cf0285b..bf3253188b 100644 --- a/compiler/typecheck/TcHoleErrors.hs +++ b/compiler/typecheck/TcHoleErrors.hs @@ -50,7 +50,7 @@ import TcUnify ( tcSubType_NC ) import ExtractDocs ( extractDocs ) import qualified Data.Map as Map -import HsDoc ( unpackHDS, DeclDocMap(..) ) +import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) import HscTypes ( ModIface(..) ) import LoadIface ( loadInterfaceForNameMaybe ) diff --git a/compiler/typecheck/TcHoleFitTypes.hs b/compiler/typecheck/TcHoleFitTypes.hs index 8700cc1399..fccf47eb54 100644 --- a/compiler/typecheck/TcHoleFitTypes.hs +++ b/compiler/typecheck/TcHoleFitTypes.hs @@ -12,7 +12,7 @@ import TcType import RdrName -import HsDoc +import GHC.Hs.Doc import Id import Outputable diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index d80505ea63..cd15db5bfd 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -48,7 +48,7 @@ module TcHsSyn ( import GhcPrelude -import HsSyn +import GHC.Hs import Id import IdInfo import TcRnMonad diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 328290a2f8..37cc83e4ca 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -64,7 +64,7 @@ module TcHsType ( import GhcPrelude -import HsSyn +import GHC.Hs import TcRnMonad import TcEvidence import TcEnv @@ -403,7 +403,7 @@ argument, which we do not want because users should be able to write solution is to switch the PartialTypeSignatures flags here to let the typechecker know that it's checking a '@_' and do not emit hole constraints on it. See related Note [Wildcards in visible kind -application] and Note [The wildcard story for types] in HsTypes.hs +application] and Note [The wildcard story for types] in GHC.Hs.Types Ugh! @@ -734,7 +734,7 @@ tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind ; checkWiredInTyCon listTyCon ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } --- See Note [Distinguishing tuple kinds] in HsTypes +-- See Note [Distinguishing tuple kinds] in GHC.Hs.Types -- See Note [Inferring tuple kinds] tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind -- (NB: not zonking before looking at exp_k, to avoid left-right bias) @@ -892,7 +892,7 @@ And whenever we see a '@', we automatically turn on PartialTypeSignatures and turn off hole constraint warnings, and do not call emitAnonWildCardHoleConstraint under these conditions. See related Note [Wildcards in visible type application] here and -Note [The wildcard story for types] in HsTypes.hs +Note [The wildcard story for types] in GHC.Hs.Types -} @@ -1752,7 +1752,7 @@ tcNamedWildCardBinders :: [Name] -> TcM a -- Bring into scope the /named/ wildcard binders. Remember that -- plain wildcards _ are anonymous and dealt with by HsWildCardTy --- Soe Note [The wildcard story for types] in HsTypes +-- Soe Note [The wildcard story for types] in GHC.Hs.Types tcNamedWildCardBinders wc_names thing_inside = do { wcs <- mapM (const newWildTyVar) wc_names ; let wc_prs = wc_names `zip` wcs @@ -1802,7 +1802,7 @@ It has two cases: -- Used in 'getInitialKind' (for tycon kinds and other kinds) -- and in kind-checking (but not for tycon kinds, which are checked with -- tcTyClDecls). See Note [CUSKs: complete user-supplied kind signatures] --- in HsDecls. +-- in GHC.Hs.Decls. -- -- This function does not do telescope checking. kcLHsQTyVars :: Name -- ^ of the thing being checked @@ -2002,7 +2002,7 @@ kcLHsQTyVarBndrs: * The tcLookupLocal_maybe code in kc_hs_tv See Note [Associated type tyvar names] in Class and - Note [TyVar binders for associated decls] in HsDecls + Note [TyVar binders for associated decls] in GHC.Hs.Decls We must do the same for family instance decls, where the in-scope variables may be bound by the enclosing class instance decl. diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index bc5e9ae244..e9d75fb17f 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -16,7 +16,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where import GhcPrelude -import HsSyn +import GHC.Hs import TcBinds import TcTyClsDecls import TcTyDecls ( addTyConsToGblEnv ) diff --git a/compiler/typecheck/TcInstDcls.hs-boot b/compiler/typecheck/TcInstDcls.hs-boot index ea0f50fd36..c65016efa0 100644 --- a/compiler/typecheck/TcInstDcls.hs-boot +++ b/compiler/typecheck/TcInstDcls.hs-boot @@ -5,7 +5,7 @@ module TcInstDcls ( tcInstDecls1 ) where -import HsSyn +import GHC.Hs import TcRnTypes import TcEnv( InstInfo ) import TcDeriv diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index b2233b4964..3f56fc8e45 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -25,7 +25,7 @@ import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) import BasicTypes (LexicalFixity(..)) -import HsSyn +import GHC.Hs import TcRnMonad import TcEnv import TcPat @@ -516,7 +516,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in HsExpr + -- See Note [GroupStmt binder map] in GHC.Hs.Expr n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids bindersMap' = bndr_ids `zip` n_bndr_ids @@ -696,7 +696,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in HsExpr + -- See Note [GroupStmt binder map] in GHC.Hs.Expr n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids bindersMap' = bndr_ids `zip` n_bndr_ids diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot index 42640151ce..9c6b914422 100644 --- a/compiler/typecheck/TcMatches.hs-boot +++ b/compiler/typecheck/TcMatches.hs-boot @@ -1,11 +1,11 @@ module TcMatches where -import HsSyn ( GRHSs, MatchGroup, LHsExpr ) +import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) import TcEvidence( HsWrapper ) import Name ( Name ) import TcType ( ExpSigmaType, TcRhoType ) import TcRnTypes( TcM ) import SrcLoc ( Located ) -import HsExtension ( GhcRn, GhcTcId ) +import GHC.Hs.Extension ( GhcRn, GhcTcId ) tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index fae16723fa..7ecfb61d7d 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -21,7 +21,7 @@ import GhcPrelude import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma ) -import HsSyn +import GHC.Hs import TcHsSyn import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags ) import TcRnMonad diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index b2b552725f..28ec8471ff 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -16,7 +16,7 @@ module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind import GhcPrelude -import HsSyn +import GHC.Hs import TcPat import Type( tidyTyCoVarBinders, tidyTypes, tidyType ) import TcRnMonad diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot index 3538682f69..950d03811a 100644 --- a/compiler/typecheck/TcPatSyn.hs-boot +++ b/compiler/typecheck/TcPatSyn.hs-boot @@ -1,10 +1,10 @@ module TcPatSyn where -import HsSyn ( PatSynBind, LHsBinds ) +import GHC.Hs ( PatSynBind, LHsBinds ) import TcRnTypes ( TcM, TcSigInfo ) import TcRnMonad ( TcGblEnv) import Outputable ( Outputable ) -import HsExtension ( GhcRn, GhcTc ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) import Data.Maybe ( Maybe ) tcPatSynDecl :: PatSynBind GhcRn GhcRn diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 2fd8359477..6c61487152 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -64,7 +64,7 @@ import MkId import TysWiredIn ( unitTy, mkListTy ) import Plugins import DynFlags -import HsSyn +import GHC.Hs import IfaceSyn ( ShowSub(..), showToHeader ) import IfaceType( ShowForAllFlag(..) ) import PatSyn( pprPatSynType ) @@ -134,7 +134,7 @@ import Bag import Inst (tcGetInsts) import qualified GHC.LanguageExtensions as LangExt import Data.Data ( Data ) -import HsDumpAst +import GHC.Hs.Dump import qualified Data.Set as S import Control.DeepSeq diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs index 4ac969ffcf..0b405d3c9e 100644 --- a/compiler/typecheck/TcRnExports.hs +++ b/compiler/typecheck/TcRnExports.hs @@ -9,7 +9,7 @@ module TcRnExports (tcRnExports, exports_from_avail) where import GhcPrelude -import HsSyn +import GHC.Hs import PrelNames import RdrName import TcRnMonad diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index dfc80ed764..f788b3e001 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -148,7 +148,7 @@ import TcRnTypes -- Re-export all import IOEnv -- Re-export all import TcEvidence -import HsSyn hiding (LIE) +import GHC.Hs hiding (LIE) import HscTypes import Module import RdrName diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index fe7db11404..8f301a0391 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -149,7 +149,7 @@ module TcRnTypes( import GhcPrelude -import HsSyn +import GHC.Hs import CoreSyn import HscTypes import TcEvidence diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs index 4146c8900c..41a7be18b7 100644 --- a/compiler/typecheck/TcRules.hs +++ b/compiler/typecheck/TcRules.hs @@ -13,7 +13,7 @@ module TcRules ( tcRules ) where import GhcPrelude -import HsSyn +import GHC.Hs import TcRnTypes import TcRnMonad import TcSimplify diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index f6505152f8..3aa16a83f5 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -27,7 +27,7 @@ module TcSigs( import GhcPrelude -import HsSyn +import GHC.Hs import TcHsType import TcRnTypes import TcRnMonad diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 3534757af1..2c930cbd30 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -31,7 +31,7 @@ import GhcPrelude import Bag import Class ( Class, classKey, classTyCon ) import DynFlags -import HsExpr ( UnboundVar(..) ) +import GHC.Hs.Expr ( UnboundVar(..) ) import Id ( idType, mkLocalId ) import Inst import ListSetOps diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 242028f578..05c2b0fd10 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -33,7 +33,7 @@ module TcSplice( import GhcPrelude -import HsSyn +import GHC.Hs import Annotations import Finder import Name @@ -60,7 +60,7 @@ import HscMain import RnSplice( traceSplice, SpliceInfo(..)) import RdrName import HscTypes -import Convert +import GHC.ThToHs import RnExpr import RnEnv import RnUtils ( HsDocContext(..) ) @@ -256,7 +256,7 @@ very straightforwardly: 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) 2. runMetaT: desugar, compile, run it, and convert result back to - HsSyn RdrName (of the appropriate flavour, eg HsType RdrName, + GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, HsExpr RdrName etc) 3. treat the result as if that's what you saw in the first place diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot index 8fb294bfc6..8cab536a01 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -5,13 +5,13 @@ module TcSplice where import GhcPrelude import Name -import HsExpr ( PendingRnSplice, DelayedSplice ) +import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice ) import TcRnTypes( TcM , SpliceType ) import TcType ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget ) -import HsExtension ( GhcTcId, GhcRn, GhcPs, GhcTc ) +import GHC.Hs.Extension ( GhcTcId, GhcRn, GhcPs, GhcTc ) -import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, +import GHC.Hs ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers ) import qualified Language.Haskell.TH as TH diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 36d5807495..69c909f4a1 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -26,7 +26,7 @@ module TcTyClsDecls ( import GhcPrelude -import HsSyn +import GHC.Hs import HscTypes import BuildTyCl import TcRnMonad @@ -151,7 +151,7 @@ tcTyAndClassDecls tyclds_s tcTyClGroup :: TyClGroup GhcRn -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo]) -- Typecheck one strongly-connected component of type, class, and instance decls --- See Note [TyClGroups and dependency analysis] in HsDecls +-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds }) diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 94658c2413..132ced5fae 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -38,7 +38,7 @@ import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) import TcType import TysWiredIn( unitTy ) import MkCore( rEC_SEL_ERROR_ID ) -import HsSyn +import GHC.Hs import Class import Type import HscTypes diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index e2a0e66cd8..f85f647632 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -34,7 +34,7 @@ import Type import TyCon import DataCon import Module -import HsSyn +import GHC.Hs import DynFlags import Bag import Var ( VarBndr(..) ) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 45cc3f9168..e1fed8d2b3 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -40,7 +40,7 @@ module TcUnify ( import GhcPrelude -import HsSyn +import GHC.Hs import TyCoRep import TcMType import TcRnMonad diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot index 295c85eb73..3b12153704 100644 --- a/compiler/typecheck/TcUnify.hs-boot +++ b/compiler/typecheck/TcUnify.hs-boot @@ -1,12 +1,12 @@ module TcUnify where import GhcPrelude -import TcType ( TcTauType ) -import TcRnTypes ( TcM ) -import TcEvidence ( TcCoercion ) -import HsExpr ( HsExpr ) -import HsTypes ( HsType ) -import HsExtension ( GhcRn ) +import TcType ( TcTauType ) +import TcRnTypes ( TcM ) +import TcEvidence ( TcCoercion ) +import GHC.Hs.Expr ( HsExpr ) +import GHC.Hs.Types ( HsType ) +import GHC.Hs.Extension ( GhcRn ) -- This boot file exists only to tie the knot between -- TcUnify and Inst diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 045f3c9f18..eaec2dbd2f 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -42,7 +42,7 @@ import TyCon -- others: import IfaceType( pprIfaceType, pprIfaceTypeApp ) import ToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) -import HsSyn -- HsType +import GHC.Hs -- HsType import TcRnMonad -- TcType, amongst others import TcEnv ( tcInitTidyEnv, tcInitOpenTidyEnv ) import FunDeps diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 45fdb411ab..19f3f0ee56 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -398,7 +398,7 @@ invariant that if `famTcInj` is a Just then at least one element in the list must be True. See also: - * [Injectivity annotation] in HsDecls + * [Injectivity annotation] in GHC.Hs.Decls * [Renaming injectivity annotation] in RnSource * [Verifying injectivity annotation] in FamInstEnv * [Type inference for type families with injectivity] in TcInteract diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index f574132c4f..39a07c2fed 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -3131,7 +3131,7 @@ There are a couple of places in GHC where we convert Core Types into forms that more closely resemble user-written syntax. These include: 1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) -2. Converting Types to LHsTypes (in HsUtils.typeToLHsType, or in Haddock) +2. Converting Types to LHsTypes (in GHC.Hs.Utils.typeToLHsType, or in Haddock) This conversion presents a challenge: how do we ensure that the resulting type has enough kind information so as not to be ambiguous? To better motivate this @@ -3171,7 +3171,7 @@ require a kind signature? It might require it when we need to fill in any of T's omitted arguments. By "omitted argument", we mean one that is dropped when reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and specified arguments (e.g., TH reification in TcSplice), and sometimes the -omitted arguments are only the inferred ones (e.g., in HsUtils.typeToLHsType, +omitted arguments are only the inferred ones (e.g., in GHC.Hs.Utils.typeToLHsType, which reifies specified arguments through visible kind application). Regardless, the key idea is that _some_ arguments are going to be omitted after reification, and the only mechanism we have at our disposal for filling them in @@ -3269,7 +3269,7 @@ each form of tycon binder: injective_vars_of_binder(forall a. ...) = {a}.) There are some situations where using visible kind application is appropriate - (e.g., HsUtils.typeToLHsType) and others where it is not (e.g., TH + (e.g., GHC.Hs.Utils.typeToLHsType) and others where it is not (e.g., TH reification), so the `injective_vars_of_binder` function is parametrized by a Bool which decides if specified binders should be counted towards injective positions or not. diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst index 6b6a1ed3cb..7035e02465 100644 --- a/docs/users_guide/extending_ghc.rst +++ b/docs/users_guide/extending_ghc.rst @@ -752,13 +752,13 @@ displayed. import Plugins import HscTypes import TcRnTypes - import HsExtension - import HsDecls - import HsExpr - import HsImpExp + import GHC.Hs.Extension + import GHC.Hs.Decls + import GHC.Hs.Expr + import GHC.Hs.ImpExp import Avail import Outputable - import HsDoc + import GHC.Hs.Doc plugin :: Plugin plugin = defaultPlugin diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index f5cae41578..87204824d1 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -52,8 +52,8 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), GetDocsFailure(..), getModuleGraph, handleSourceError ) import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation) -import HsImpExp -import HsSyn +import GHC.Hs.ImpExp +import GHC.Hs import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc, hsc_dynLinker ) diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 8bdeb04834..aa09af2f15 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -51,8 +51,8 @@ import RdrName (mkOrig) import PrelNames (gHC_GHCI_HELPERS) import GHCi import GHCi.RemoteTypes -import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl) -import HsUtils +import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl) +import GHC.Hs.Utils import Util import Exception diff --git a/nofib b/nofib index 52e761b9bc..a6cbac8fd8 160000 --- a/nofib +++ b/nofib @@ -1 +1 @@ -Subproject commit 52e761b9bc05e4b90f0a9d780a0f2cae9cbbb67b +Subproject commit a6cbac8fd8c69d85fddfde0a2686607e1ae22947 diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs index 1b5803b817..8bae838672 100644 --- a/testsuite/tests/ghc-api/annotations/stringSource.hs +++ b/testsuite/tests/ghc-api/annotations/stringSource.hs @@ -17,7 +17,7 @@ import FastString import ForeignCall import MonadUtils import Outputable -import HsDecls +import GHC.Hs.Decls import Bag (filterBag,isEmptyBag) import System.Directory (removeFile) import System.Environment( getArgs ) diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs index 232d47ff98..f161e601ce 100644 --- a/testsuite/tests/ghc-api/annotations/t11430.hs +++ b/testsuite/tests/ghc-api/annotations/t11430.hs @@ -17,7 +17,7 @@ import FastString import ForeignCall import MonadUtils import Outputable -import HsDecls +import GHC.Hs.Decls import Bag (filterBag,isEmptyBag) import System.Directory (removeFile) import System.Environment( getArgs ) diff --git a/testsuite/tests/package/all.T b/testsuite/tests/package/all.T index 869abb1a7a..8fe654fb7d 100644 --- a/testsuite/tests/package/all.T +++ b/testsuite/tests/package/all.T @@ -1,7 +1,7 @@ hide_all = '-hide-all-packages -XNoImplicitPrelude ' incr_containers = '-package "containers (Data.Map as Map, Data.Set)" ' inc_containers = '-package containers ' -incr_ghc = '-package "ghc (HsTypes as MyHsTypes, HsUtils)" ' +incr_ghc = '-package "ghc (GHC.Hs.Types as GHC.Hs.MyTypes, GHC.Hs.Utils)" ' inc_ghc = '-package ghc ' hide_ghc = '-hide-package ghc ' diff --git a/testsuite/tests/package/package05.hs b/testsuite/tests/package/package05.hs index 3b0069c5d5..e2c1125321 100644 --- a/testsuite/tests/package/package05.hs +++ b/testsuite/tests/package/package05.hs @@ -1,4 +1,4 @@ module Package05 where -import HsTypes -import MyHsTypes -import HsUtils +import GHC.Hs.Types +import GHC.Hs.MyTypes +import GHC.Hs.Utils diff --git a/testsuite/tests/package/package06.hs b/testsuite/tests/package/package06.hs index 096b81b7ba..ce9ce6fb84 100644 --- a/testsuite/tests/package/package06.hs +++ b/testsuite/tests/package/package06.hs @@ -1,3 +1,3 @@ module Package06 where -import MyHsTypes -import HsUtils +import GHC.Hs.MyTypes +import GHC.Hs.Utils diff --git a/testsuite/tests/package/package06e.hs b/testsuite/tests/package/package06e.hs index 6feaebda62..35b6ceaa76 100644 --- a/testsuite/tests/package/package06e.hs +++ b/testsuite/tests/package/package06e.hs @@ -1,3 +1,3 @@ module Package06e where -import HsTypes +import GHC.Hs.Types import UniqFM diff --git a/testsuite/tests/package/package06e.stderr b/testsuite/tests/package/package06e.stderr index 12d721223c..98f048c107 100644 --- a/testsuite/tests/package/package06e.stderr +++ b/testsuite/tests/package/package06e.stderr @@ -1,6 +1,6 @@ package06e.hs:2:1: error: - Could not load module ‘HsTypes’ + Could not load module ‘GHC.Hs.Types’ It is a member of the hidden package ‘ghc-8.7’. You can run ‘:set -package ghc’ to expose it. (Note: this unloads all the modules in the current scope.) diff --git a/testsuite/tests/package/package07e.hs b/testsuite/tests/package/package07e.hs index 85bb723989..df13ed734e 100644 --- a/testsuite/tests/package/package07e.hs +++ b/testsuite/tests/package/package07e.hs @@ -1,5 +1,5 @@ module Package07e where -import MyHsTypes -import HsTypes -import HsUtils +import GHC.Hs.MyTypes +import GHC.Hs.Types +import GHC.Hs.Utils import UniqFM diff --git a/testsuite/tests/package/package07e.stderr b/testsuite/tests/package/package07e.stderr index 2678972a78..5f5f0b9885 100644 --- a/testsuite/tests/package/package07e.stderr +++ b/testsuite/tests/package/package07e.stderr @@ -1,18 +1,18 @@ package07e.hs:2:1: error: - Could not find module ‘MyHsTypes’ - Perhaps you meant HsTypes (needs flag -package-key ghc-8.7) + Could not find module ‘GHC.Hs.MyTypes’ + Perhaps you meant GHC.Hs.Types (needs flag -package-key ghc-8.7) Use -v (or `:set -v` in ghci) to see a list of the files searched for. package07e.hs:3:1: error: - Could not load module ‘HsTypes’ + Could not load module ‘GHC.Hs.Types’ It is a member of the hidden package ‘ghc-8.7’. You can run ‘:set -package ghc’ to expose it. (Note: this unloads all the modules in the current scope.) Use -v (or `:set -v` in ghci) to see a list of the files searched for. package07e.hs:4:1: error: - Could not load module ‘HsUtils’ + Could not load module ‘GHC.Hs.Utils’ It is a member of the hidden package ‘ghc-8.7’. You can run ‘:set -package ghc’ to expose it. (Note: this unloads all the modules in the current scope.) diff --git a/testsuite/tests/package/package08e.hs b/testsuite/tests/package/package08e.hs index 40f814449a..aba05de9ca 100644 --- a/testsuite/tests/package/package08e.hs +++ b/testsuite/tests/package/package08e.hs @@ -1,5 +1,5 @@ module Package08e where -import MyHsTypes -import HsTypes -import HsUtils +import GHC.Hs.MyTypes +import GHC.Hs.Types +import GHC.Hs.Utils import UniqFM diff --git a/testsuite/tests/package/package08e.stderr b/testsuite/tests/package/package08e.stderr index f02e9d6da3..46d665bceb 100644 --- a/testsuite/tests/package/package08e.stderr +++ b/testsuite/tests/package/package08e.stderr @@ -1,18 +1,18 @@ package08e.hs:2:1: error: - Could not find module ‘MyHsTypes’ - Perhaps you meant HsTypes (needs flag -package-key ghc-8.7) + Could not find module ‘GHC.Hs.MyTypes’ + Perhaps you meant GHC.Hs.Types (needs flag -package-key ghc-8.7) Use -v (or `:set -v` in ghci) to see a list of the files searched for. package08e.hs:3:1: error: - Could not load module ‘HsTypes’ + Could not load module ‘GHC.Hs.Types’ It is a member of the hidden package ‘ghc-8.7’. You can run ‘:set -package ghc’ to expose it. (Note: this unloads all the modules in the current scope.) Use -v (or `:set -v` in ghci) to see a list of the files searched for. package08e.hs:4:1: error: - Could not load module ‘HsUtils’ + Could not load module ‘GHC.Hs.Utils’ It is a member of the hidden package ‘ghc-8.7’. You can run ‘:set -package ghc’ to expose it. (Note: this unloads all the modules in the current scope.) diff --git a/testsuite/tests/parser/should_fail/readFail001.hs b/testsuite/tests/parser/should_fail/readFail001.hs index 6b186922f3..a3faa1b5e5 100644 --- a/testsuite/tests/parser/should_fail/readFail001.hs +++ b/testsuite/tests/parser/should_fail/readFail001.hs @@ -51,7 +51,7 @@ instance (Eq a) => EqClass (Tree a) where default (Integer, Rational) --- HsBinds stuff +-- GHC.Hs.Binds stuff singlebind x = x diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index 2d14eeaf85..fce8b7d136 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -7,12 +7,12 @@ import Plugins import Bag import HscTypes import TcRnTypes -import HsExtension -import HsExpr +import GHC.Hs.Extension +import GHC.Hs.Expr import Outputable import SrcLoc -import HsSyn -import HsBinds +import GHC.Hs +import GHC.Hs.Binds import OccName import RdrName import Name diff --git a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs index b9bdaeb37a..cb5fc70550 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs @@ -6,13 +6,13 @@ import Data.Maybe (isJust) import Plugins import HscTypes import TcRnTypes -import HsExtension +import GHC.Hs.Extension import Avail -import HsExpr +import GHC.Hs.Expr import Outputable -import HsImpExp -import HsDecls -import HsDoc +import GHC.Hs.ImpExp +import GHC.Hs.Decls +import GHC.Hs.Doc plugin :: Plugin plugin = defaultPlugin { parsedResultAction = parsedPlugin diff --git a/testsuite/tests/plugins/static-plugins.hs b/testsuite/tests/plugins/static-plugins.hs index 36e18b86b5..3dd6aa2e6d 100644 --- a/testsuite/tests/plugins/static-plugins.hs +++ b/testsuite/tests/plugins/static-plugins.hs @@ -6,11 +6,11 @@ import DynFlags (getDynFlags, parseDynamicFlagsCmdLine, defaultFatalMessager, defaultFlushOut) import GHC import GHC.Fingerprint.Type -import HsDecls -import HsDoc -import HsExpr -import HsExtension -import HsImpExp +import GHC.Hs.Decls +import GHC.Hs.Doc +import GHC.Hs.Expr +import GHC.Hs.Extension +import GHC.Hs.ImpExp import HscTypes import Outputable import Plugins diff --git a/testsuite/tests/pmcheck/should_compile/pmc009.hs b/testsuite/tests/pmcheck/should_compile/pmc009.hs index ac8f5c2dd5..08f130de33 100644 --- a/testsuite/tests/pmcheck/should_compile/pmc009.hs +++ b/testsuite/tests/pmcheck/should_compile/pmc009.hs @@ -1,5 +1,5 @@ module HsUtils where -import HsBinds +import GHC.Hs.Binds import SrcLoc diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs index a5aeee2f1d..8a86d02e7c 100644 --- a/utils/check-ppr/Main.hs +++ b/utils/check-ppr/Main.hs @@ -3,7 +3,7 @@ import Data.List import SrcLoc import GHC hiding (moduleName) -import HsDumpAst +import GHC.Hs.Dump import DynFlags import Outputable hiding (space) import System.Environment( getArgs ) diff --git a/utils/haddock b/utils/haddock index 75f71980df..58933236f1 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit 75f71980dfcd9a009e2eeb3a8690a473f47fcdfe +Subproject commit 58933236f116a26a2827b0cb5c46947e4f056c77 -- cgit v1.2.1