...
 
Commits (3)
...@@ -67,6 +67,7 @@ import Text.ParserCombinators.ReadP (readP_to_S) ...@@ -67,6 +67,7 @@ import Text.ParserCombinators.ReadP (readP_to_S)
import GHC hiding (verbosity) import GHC hiding (verbosity)
import GHC.Settings.Config import GHC.Settings.Config
import GHC.Driver.Session hiding (projectVersion, verbosity) import GHC.Driver.Session hiding (projectVersion, verbosity)
import GHC.Driver.Backend
import GHC.Utils.Error import GHC.Utils.Error
import GHC.Unit import GHC.Unit
import GHC.Utils.Panic (handleGhcException) import GHC.Utils.Panic (handleGhcException)
...@@ -495,9 +496,9 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do ...@@ -495,9 +496,9 @@ withGhc' libDir needHieFiles flags ghcActs = runGhc (Just libDir) $ do
let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock] let extra_opts | needHieFiles = [Opt_WriteHie, Opt_Haddock]
| otherwise = [Opt_Haddock] | otherwise = [Opt_Haddock]
dynflags' = (foldl' gopt_set dynflags extra_opts) dynflags' = (foldl' gopt_set dynflags extra_opts)
{ hscTarget = HscNothing { backend = NoBackend
, ghcMode = CompManager , ghcMode = CompManager
, ghcLink = NoLink , ghcLink = NoLink
} }
flags' = filterRtsFlags flags flags' = filterRtsFlags flags
......
...@@ -69,7 +69,7 @@ ppModule dflags iface = ...@@ -69,7 +69,7 @@ ppModule dflags iface =
--------------------------------------------------------------------- ---------------------------------------------------------------------
-- Utility functions -- Utility functions
dropHsDocTy :: HsType a -> HsType a dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p)
dropHsDocTy = f dropHsDocTy = f
where where
g (L src x) = L src (f x) g (L src x) = L src (f x)
......
...@@ -240,7 +240,6 @@ classify tok = ...@@ -240,7 +240,6 @@ classify tok =
ITcolumn_prag {} -> TkPragma ITcolumn_prag {} -> TkPragma
ITscc_prag {} -> TkPragma ITscc_prag {} -> TkPragma
ITgenerated_prag {} -> TkPragma ITgenerated_prag {} -> TkPragma
ITcore_prag {} -> TkPragma
ITunpack_prag {} -> TkPragma ITunpack_prag {} -> TkPragma
ITnounpack_prag {} -> TkPragma ITnounpack_prag {} -> TkPragma
ITann_prag {} -> TkPragma ITann_prag {} -> TkPragma
...@@ -381,7 +380,6 @@ inPragma False tok = ...@@ -381,7 +380,6 @@ inPragma False tok =
ITcolumn_prag {} -> True ITcolumn_prag {} -> True
ITscc_prag {} -> True ITscc_prag {} -> True
ITgenerated_prag {} -> True ITgenerated_prag {} -> True
ITcore_prag {} -> True
ITunpack_prag {} -> True ITunpack_prag {} -> True
ITnounpack_prag {} -> True ITnounpack_prag {} -> True
ITann_prag {} -> True ITann_prag {} -> True
......
...@@ -41,7 +41,6 @@ import Control.Monad ...@@ -41,7 +41,6 @@ import Control.Monad
import Data.Maybe import Data.Maybe
import Data.List import Data.List
import Prelude hiding ((<>)) import Prelude hiding ((<>))
import GHC.Core.Multiplicity
import Haddock.Doc (combineDocumentation) import Haddock.Doc (combineDocumentation)
......
...@@ -41,7 +41,6 @@ import GHC.Exts ...@@ -41,7 +41,6 @@ import GHC.Exts
import GHC.Types.Name import GHC.Types.Name
import GHC.Data.BooleanFormula import GHC.Data.BooleanFormula
import GHC.Types.Name.Reader ( rdrNameOcc ) import GHC.Types.Name.Reader ( rdrNameOcc )
import GHC.Core.Multiplicity
-- | Pretty print a declaration -- | Pretty print a declaration
ppDecl :: Bool -- ^ print summary info only ppDecl :: Bool -- ^ print summary info only
...@@ -1143,18 +1142,16 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ...@@ -1143,18 +1142,16 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts ppKind unicode qual ki = ppr_mono_ty (reparenTypePrec PREC_TOP ki) unicode qual HideEmptyContexts
patSigContext :: LHsType name -> HideEmptyContexts patSigContext :: LHsType DocNameI -> HideEmptyContexts
patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts
| otherwise = HideEmptyContexts | otherwise = HideEmptyContexts
where where
hasNonEmptyContext :: LHsType name -> Bool
hasNonEmptyContext t = hasNonEmptyContext t =
case unLoc t of case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s HsForAllTy _ _ s -> hasNonEmptyContext s
HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
HsFunTy _ _ _ s -> hasNonEmptyContext s HsFunTy _ _ _ s -> hasNonEmptyContext s
_ -> False _ -> False
isFirstContextEmpty :: LHsType name -> Bool
isFirstContextEmpty t = isFirstContextEmpty t =
case unLoc t of case unLoc t of
HsForAllTy _ _ s -> isFirstContextEmpty s HsForAllTy _ _ s -> isFirstContextEmpty s
......
...@@ -35,7 +35,6 @@ import GHC.Types.Name ...@@ -35,7 +35,6 @@ import GHC.Types.Name
import GHC.Types.Name.Set ( emptyNameSet ) import GHC.Types.Name.Set ( emptyNameSet )
import GHC.Types.Name.Reader ( mkVarUnqual ) import GHC.Types.Name.Reader ( mkVarUnqual )
import GHC.Core.PatSyn import GHC.Core.PatSyn
import GHC.Types.SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )
import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcType
import GHC.Core.TyCon import GHC.Core.TyCon
import GHC.Core.Type import GHC.Core.Type
...@@ -57,7 +56,6 @@ import Haddock.Types ...@@ -57,7 +56,6 @@ import Haddock.Types
import Haddock.Interface.Specialize import Haddock.Interface.Specialize
import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars ) import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars )
import GHC.Core.Multiplicity
import Data.Maybe ( catMaybes, mapMaybe, maybeToList ) import Data.Maybe ( catMaybes, mapMaybe, maybeToList )
......
{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-} {-# OPTIONS_HADDOCK hide #-}
...@@ -23,17 +26,14 @@ import Data.Char ( isSpace ) ...@@ -23,17 +26,14 @@ import Data.Char ( isSpace )
import Haddock.Types( DocName, DocNameI ) import Haddock.Types( DocName, DocNameI )
import GHC.Utils.Exception
import GHC.Utils.FV as FV import GHC.Utils.FV as FV
import GHC.Utils.Outputable ( Outputable, panic, showPpr ) import GHC.Utils.Outputable ( Outputable, panic, showPpr )
import GHC.Types.Name import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Unit.Module import GHC.Unit.Module
import GHC.Driver.Types import GHC.Driver.Types
import GHC import GHC
import GHC.Core.Class import GHC.Core.Class
import GHC.Driver.Session import GHC.Driver.Session
import GHC.Core.Multiplicity
import GHC.Types.SrcLoc ( advanceSrcLoc ) import GHC.Types.SrcLoc ( advanceSrcLoc )
import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
, tyVarKind, updateTyVarKind, isInvisibleArgFlag ) , tyVarKind, updateTyVarKind, isInvisibleArgFlag )
...@@ -50,6 +50,8 @@ import Data.ByteString ( ByteString ) ...@@ -50,6 +50,8 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Internal as BS
import GHC.HsToCore.Docs
moduleString :: Module -> String moduleString :: Module -> String
moduleString = moduleNameString . moduleName moduleString = moduleNameString . moduleName
...@@ -89,25 +91,12 @@ ifTrueJust :: Bool -> name -> Maybe name ...@@ -89,25 +91,12 @@ ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust True = Just ifTrueJust True = Just
ifTrueJust False = const Nothing ifTrueJust False = const Nothing
sigName :: LSig name -> [IdP name] sigName :: LSig GhcRn -> [IdP GhcRn]
sigName (L _ sig) = sigNameNoLoc sig sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [IdP name]
sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
sigNameNoLoc (InlineSig _ n _) = [unLoc n]
sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
sigNameNoLoc _ = []
-- | Was this signature given by the user? -- | Was this signature given by the user?
isUserLSig :: LSig name -> Bool isUserLSig :: forall p. UnXRec p => LSig p -> Bool
isUserLSig (L _ (TypeSig {})) = True isUserLSig = isUserSig . unXRec @p
isUserLSig (L _ (ClassOpSig {})) = True
isUserLSig (L _ (PatSynSig {})) = True
isUserLSig _ = False
isClassD :: HsDecl a -> Bool isClassD :: HsDecl a -> Bool
isClassD (TyClD _ d) = isClassDecl d isClassD (TyClD _ d) = isClassDecl d
...@@ -258,18 +247,18 @@ data Precedence ...@@ -258,18 +247,18 @@ data Precedence
-- --
-- We cannot add parens that may be required by fixities because we do not have -- We cannot add parens that may be required by fixities because we do not have
-- any fixity information to work with in the first place :(. -- any fixity information to work with in the first place :(.
reparenTypePrec :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a reparenTypePrec :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => Precedence -> HsType a -> HsType a
reparenTypePrec = go reparenTypePrec = go
where where
-- Shorter name for 'reparenType' -- Shorter name for 'reparenType'
go :: (XParTy a ~ NoExtField) => Precedence -> HsType a -> HsType a go :: Precedence -> HsType a -> HsType a
go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty) go _ (HsBangTy x b ty) = HsBangTy x b (reparenLType ty)
go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys) go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys) go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind) go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind)
go _ (HsListTy x ty) = HsListTy x (reparenLType ty) go _ (HsListTy x ty) = HsListTy x (reparenLType ty)
go _ (HsRecTy x flds) = HsRecTy x (map (fmap reparenConDeclField) flds) go _ (HsRecTy x flds) = HsRecTy x (map (mapXRec @a reparenConDeclField) flds)
go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d go p (HsDocTy x ty d) = HsDocTy x (goL p ty) d
go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys) go _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys) go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
...@@ -278,7 +267,7 @@ reparenTypePrec = go ...@@ -278,7 +267,7 @@ reparenTypePrec = go
go p (HsForAllTy x tele ty) go p (HsForAllTy x tele ty)
= paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty) = paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType ty)
go p (HsQualTy x ctxt ty) go p (HsQualTy x ctxt ty)
= paren p PREC_FUN $ HsQualTy x (fmap (map reparenLType) ctxt) (reparenLType ty) = paren p PREC_FUN $ HsQualTy x (mapXRec @a (map reparenLType) ctxt) (reparenLType ty)
go p (HsFunTy x w ty1 ty2) go p (HsFunTy x w ty1 ty2)
= paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2) = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty) go p (HsAppTy x fun_ty arg_ty)
...@@ -287,7 +276,7 @@ reparenTypePrec = go ...@@ -287,7 +276,7 @@ reparenTypePrec = go
= paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki) = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
go p (HsOpTy x ty1 op ty2) go p (HsOpTy x ty1 op ty2)
= paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) = paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2)
go p (HsParTy _ t) = unLoc $ goL p t -- pretend the paren doesn't exist - it will be added back if needed go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed
go _ t@HsTyVar{} = t go _ t@HsTyVar{} = t
go _ t@HsStarTy{} = t go _ t@HsStarTy{} = t
go _ t@HsSpliceTy{} = t go _ t@HsSpliceTy{} = t
...@@ -296,43 +285,42 @@ reparenTypePrec = go ...@@ -296,43 +285,42 @@ reparenTypePrec = go
go _ t@XHsType{} = t go _ t@XHsType{} = t
-- Located variant of 'go' -- Located variant of 'go'
goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a goL :: Precedence -> LHsType a -> LHsType a
goL ctxt_prec = fmap (go ctxt_prec) goL ctxt_prec = mapXRec @a (go ctxt_prec)
-- Optionally wrap a type in parens -- Optionally wrap a type in parens
paren :: (XParTy a ~ NoExtField) paren :: Precedence -- Precedence of context
=> Precedence -- Precedence of context
-> Precedence -- Precedence of top-level operator -> Precedence -- Precedence of top-level operator
-> HsType a -> HsType a -- Wrap in parens if (ctxt >= op) -> HsType a -> HsType a -- Wrap in parens if (ctxt >= op)
paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . noLoc paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a
| otherwise = id | otherwise = id
-- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec')
reparenType :: (XParTy a ~ NoExtField) => HsType a -> HsType a reparenType :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsType a -> HsType a
reparenType = reparenTypePrec PREC_TOP reparenType = reparenTypePrec PREC_TOP
-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a reparenLType :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a
reparenLType = fmap reparenType reparenLType = mapXRec @a reparenType
-- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec')
reparenHsForAllTelescope :: (XParTy a ~ NoExtField) reparenHsForAllTelescope :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a)
=> HsForAllTelescope a -> HsForAllTelescope a => HsForAllTelescope a -> HsForAllTelescope a
reparenHsForAllTelescope (HsForAllVis x bndrs) = reparenHsForAllTelescope (HsForAllVis x bndrs) =
HsForAllVis x (map (fmap reparenTyVar) bndrs) HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope (HsForAllInvis x bndrs) = reparenHsForAllTelescope (HsForAllInvis x bndrs) =
HsForAllInvis x (map (fmap reparenTyVar) bndrs) HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope v@XHsForAllTelescope{} = v reparenHsForAllTelescope v@XHsForAllTelescope{} = v
-- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec')
reparenTyVar :: (XParTy a ~ NoExtField) => HsTyVarBndr flag a -> HsTyVarBndr flag a reparenTyVar :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => HsTyVarBndr flag a -> HsTyVarBndr flag a
reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n
reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind) reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
reparenTyVar v@XTyVarBndr{} = v reparenTyVar v@XTyVarBndr{} = v
-- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec')
reparenConDeclField :: (XParTy a ~ NoExtField) => ConDeclField a -> ConDeclField a reparenConDeclField :: (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => ConDeclField a -> ConDeclField a
reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d
reparenConDeclField c@XConDeclField{} = c reparenConDeclField c@XConDeclField{} = c
......
...@@ -17,7 +17,6 @@ module Haddock.Interface.AttachInstances (attachInstances) where ...@@ -17,7 +17,6 @@ module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types import Haddock.Types
import Haddock.Convert import Haddock.Convert
import Haddock.GhcUtils
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>)) import Control.Arrow hiding ((<+>))
......
...@@ -34,7 +34,6 @@ import qualified Data.Map as M ...@@ -34,7 +34,6 @@ import qualified Data.Map as M
import Data.Map (Map) import Data.Map (Map)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Control.Applicative
import Control.Monad import Control.Monad
import Data.Traversable import Data.Traversable
...@@ -49,7 +48,6 @@ import GHC.Types.Name ...@@ -49,7 +48,6 @@ import GHC.Types.Name
import GHC.Types.Name.Set import GHC.Types.Name.Set
import GHC.Types.Name.Env import GHC.Types.Name.Env
import GHC.Unit.State import GHC.Unit.State
import GHC.Data.Bag
import GHC.Types.Name.Reader import GHC.Types.Name.Reader
import GHC.Tc.Types import GHC.Tc.Types
import GHC.Data.FastString ( unpackFS, bytesFS ) import GHC.Data.FastString ( unpackFS, bytesFS )
...@@ -57,8 +55,6 @@ import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) ) ...@@ -57,8 +55,6 @@ import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
import qualified GHC.Utils.Outputable as O import qualified GHC.Utils.Outputable as O
import GHC.HsToCore.Docs hiding (mkMaps) import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Core.Multiplicity
-- | Use a 'TypecheckedModule' to produce an 'Interface'. -- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological -- To do this, we need access to already processed modules in the topological
...@@ -240,7 +236,7 @@ mkAliasMap state mRenamedSource = ...@@ -240,7 +236,7 @@ mkAliasMap state mRenamedSource =
-- --
-- With our mapping we know that we can display exported modules M1 and M2. -- With our mapping we know that we can display exported modules M1 and M2.
-- --
unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] unrestrictedModuleImports :: [ImportDecl GhcRn] -> M.Map ModuleName [ModuleName]
unrestrictedModuleImports idecls = unrestrictedModuleImports idecls =
M.map (map (unLoc . ideclName)) M.map (map (unLoc . ideclName))
$ M.filter (all isInteresting) impModMap $ M.filter (all isInteresting) impModMap
...@@ -958,7 +954,7 @@ extractPatternSyn nm t tvs cons = ...@@ -958,7 +954,7 @@ extractPatternSyn nm t tvs cons =
typ'' = noLoc (HsQualTy noExtField (noLoc []) typ') typ'' = noLoc (HsQualTy noExtField (noLoc []) typ')
in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'') in PatSynSig noExtField [noLoc nm] (mkEmptyImplicitBndrs typ'')
longArrow :: (XFunTy name ~ NoExtField) => [LHsType name] -> LHsType name -> LHsType name longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn
longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField HsUnrestrictedArrow x y)) output inputs
data_ty con data_ty con
......
...@@ -474,7 +474,8 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType ...@@ -474,7 +474,8 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_mb_cxt = lcontext, con_args = details , con_mb_cxt = lcontext, con_args = details
, con_doc = mbldoc }) = do , con_doc = mbldoc
, con_forall = forall }) = do
lname' <- renameL lname lname' <- renameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext lcontext' <- traverse renameLContext lcontext
...@@ -482,21 +483,24 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars ...@@ -482,21 +483,24 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
mbldoc' <- mapM renameLDocHsSyn mbldoc mbldoc' <- mapM renameLDocHsSyn mbldoc
return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars' return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
, con_mb_cxt = lcontext' , con_mb_cxt = lcontext'
, con_forall = forall -- Remove when #18311 is fixed
, con_args = details', con_doc = mbldoc' }) , con_args = details', con_doc = mbldoc' })
renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars renameCon ConDeclGADT { con_names = lnames, con_qvars = ltyvars
, con_mb_cxt = lcontext, con_args = details , con_mb_cxt = lcontext, con_args = details
, con_res_ty = res_ty , con_res_ty = res_ty, con_forall = forall
, con_doc = mbldoc }) = do , con_doc = mbldoc } = do
lnames' <- mapM renameL lnames lnames' <- mapM renameL lnames
ltyvars' <- mapM renameLTyVarBndr ltyvars ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext lcontext' <- traverse renameLContext lcontext
details' <- renameDetails details details' <- renameDetails details
res_ty' <- renameLType res_ty res_ty' <- renameLType res_ty
mbldoc' <- mapM renameLDocHsSyn mbldoc mbldoc' <- mapM renameLDocHsSyn mbldoc
return (decl { con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars' return (ConDeclGADT
{ con_g_ext = noExtField, con_names = lnames', con_qvars = ltyvars'
, con_mb_cxt = lcontext', con_args = details' , con_mb_cxt = lcontext', con_args = details'
, con_res_ty = res_ty', con_doc = mbldoc' }) , con_res_ty = res_ty', con_doc = mbldoc'
, con_forall = forall}) -- Remove when #18311 is fixed
renameHsScaled :: HsScaled GhcRn (LHsType GhcRn) renameHsScaled :: HsScaled GhcRn (LHsType GhcRn)
-> RnM (HsScaled DocNameI (LHsType DocNameI)) -> RnM (HsScaled DocNameI (LHsType DocNameI))
......
...@@ -3,6 +3,7 @@ ...@@ -3,6 +3,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-}
module Haddock.Interface.Specialize module Haddock.Interface.Specialize
( specializeInstHead ( specializeInstHead
...@@ -15,7 +16,6 @@ import Haddock.Types ...@@ -15,7 +16,6 @@ import Haddock.Types
import GHC import GHC
import GHC.Types.Name import GHC.Types.Name
import GHC.Data.FastString import GHC.Data.FastString
import GHC.Builtin.Types.Prim ( funTyConName )
import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
import Control.Monad import Control.Monad
...@@ -36,7 +36,7 @@ specialize specs = go spec_map0 ...@@ -36,7 +36,7 @@ specialize specs = go spec_map0
go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x go :: forall x. Data x => Map Name (HsType GhcRn) -> x -> x
go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map go spec_map = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map
strip_kind_sig :: HsType name -> HsType name strip_kind_sig :: HsType GhcRn -> HsType GhcRn
strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig (HsKindSig _ (L _ t) _) = t
strip_kind_sig typ = typ strip_kind_sig typ = typ
...@@ -205,6 +205,7 @@ freeVariables :: HsType GhcRn -> Set Name ...@@ -205,6 +205,7 @@ freeVariables :: HsType GhcRn -> Set Name
freeVariables = freeVariables =
everythingWithState Set.empty Set.union query everythingWithState Set.empty Set.union query
where where
query :: forall a . Data a => a -> Set Name -> (Set Name, Set Name)
query term ctx = case cast term :: Maybe (HsType GhcRn) of query term ctx = case cast term :: Maybe (HsType GhcRn) of
Just (HsForAllTy _ tele _) -> Just (HsForAllTy _ tele _) ->
(Set.empty, Set.union ctx (teleNames tele)) (Set.empty, Set.union ctx (teleNames tele))
...@@ -213,6 +214,7 @@ freeVariables = ...@@ -213,6 +214,7 @@ freeVariables =
| otherwise -> (Set.singleton $ getName name, ctx) | otherwise -> (Set.singleton $ getName name, ctx)
_ -> (Set.empty, ctx) _ -> (Set.empty, ctx)
teleNames :: HsForAllTelescope GhcRn -> Set Name
teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
...@@ -366,7 +368,6 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b) ...@@ -366,7 +368,6 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e located f (L loc e) = L loc <$> f e
tyVarName :: HsTyVarBndr flag name -> IdP name tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn
tyVarName (UserTyVar _ _ name) = unLoc name tyVarName (UserTyVar _ _ name) = unLoc name
tyVarName (KindedTyVar _ _ (L _ name) _) = name tyVarName (KindedTyVar _ _ (L _ name) _) = name
tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
...@@ -669,7 +669,13 @@ instance MonadIO ErrMsgGhc where ...@@ -669,7 +669,13 @@ instance MonadIO ErrMsgGhc where
-- * Pass sensitive types -- * Pass sensitive types
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
type instance XRec DocNameI f = Located (f DocNameI) type instance XRec DocNameI a = Located a
instance UnXRec DocNameI where
unXRec = unLoc
instance MapXRec DocNameI where
mapXRec = fmap
instance WrapXRec DocNameI where
wrapXRec = noLoc
type instance XForAllTy DocNameI = NoExtField type instance XForAllTy DocNameI = NoExtField
type instance XQualTy DocNameI = NoExtField type instance XQualTy DocNameI = NoExtField
......
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
-- Module : Haddock.Utils -- Module : Haddock.Utils
...@@ -90,8 +91,6 @@ import qualified System.Posix.Internals ...@@ -90,8 +91,6 @@ import qualified System.Posix.Internals
import GHC.Utils.Monad ( MonadIO(..) ) import GHC.Utils.Monad ( MonadIO(..) )
import GHC.Core.Multiplicity
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- * Logging -- * Logging
......