diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Hs.hs | 153 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Binds.hs | 1310 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Decls.hs | 2417 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Doc.hs | 152 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Dump.hs | 220 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs | 2828 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs-boot | 51 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Extension.hs | 1168 | ||||
| -rw-r--r-- | compiler/GHC/Hs/ImpExp.hs | 366 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Instances.hs | 420 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Lit.hs | 314 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Pat.hs | 846 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Pat.hs-boot | 18 | ||||
| -rw-r--r-- | compiler/GHC/Hs/PlaceHolder.hs | 70 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Types.hs | 1724 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 1416 | ||||
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 2015 |
17 files changed, 15488 insertions, 0 deletions
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 "<default method>" +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) + +instance Outputable TcSpecPrag where + ppr (SpecPrag var _ inl) + = text "SPECIALIZE" <+> pprSpec var (text "<type>") 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 :: <type> + op2 :: <type> + 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 = :: <type> -- NB the '=' + op2 :: <type> + 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} <pragma info> + +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 = <constrs> + -- data/newtype instance T [a] = <constrs> + -- @ + 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 <the record fields> + 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 "<document comment>" + +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, <expression>)] + where <expression> 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 ("<IEGroup: " ++ show n ++ ">") + ppr (IEDoc _ doc) = ppr doc + ppr (IEDocNamed _ string) = text ("<IEDocNamed: " ++ string ++ ">") + 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 <tvs>. 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 <tvs>. 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 <tvs>. context => instance_head@) into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall <tvs>. <...>)@. 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 = <some-pattern> + +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 <some-pattern>, 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. + +-} |