...
 
Commits (1)
......@@ -69,7 +69,7 @@ ppModule dflags iface =
---------------------------------------------------------------------
-- Utility functions
dropHsDocTy :: HsType a -> HsType a
dropHsDocTy :: HsType (GhcPass p) -> HsType (GhcPass p)
dropHsDocTy = f
where
g (L src x) = L src (f x)
......
......@@ -41,7 +41,6 @@ import Control.Monad
import Data.Maybe
import Data.List
import Prelude hiding ((<>))
import GHC.Core.Multiplicity
import Haddock.Doc (combineDocumentation)
......
......@@ -41,7 +41,6 @@ import GHC.Exts
import GHC.Types.Name
import GHC.Data.BooleanFormula
import GHC.Types.Name.Reader ( rdrNameOcc )
import GHC.Core.Multiplicity
-- | Pretty print a declaration
ppDecl :: Bool -- ^ print summary info only
......@@ -1143,18 +1142,16 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y)
ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html
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
| otherwise = HideEmptyContexts
where
hasNonEmptyContext :: LHsType name -> Bool
hasNonEmptyContext t =
case unLoc t of
HsForAllTy _ _ s -> hasNonEmptyContext s
HsQualTy _ cxt s -> if null (unLoc cxt) then hasNonEmptyContext s else True
HsFunTy _ _ _ s -> hasNonEmptyContext s
_ -> False
isFirstContextEmpty :: LHsType name -> Bool
isFirstContextEmpty t =
case unLoc t of
HsForAllTy _ _ s -> isFirstContextEmpty s
......
......@@ -35,7 +35,6 @@ import GHC.Types.Name
import GHC.Types.Name.Set ( emptyNameSet )
import GHC.Types.Name.Reader ( mkVarUnqual )
import GHC.Core.PatSyn
import GHC.Types.SrcLoc ( Located, noLoc, unLoc, GenLocated(..), srcLocSpan )
import GHC.Tc.Utils.TcType
import GHC.Core.TyCon
import GHC.Core.Type
......@@ -57,7 +56,6 @@ import Haddock.Types
import Haddock.Interface.Specialize
import Haddock.GhcUtils ( orderedFVs, defaultRuntimeRepVars )
import GHC.Core.Multiplicity
import Data.Maybe ( catMaybes, mapMaybe, maybeToList )
......
{-# LANGUAGE BangPatterns, StandaloneDeriving, FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
......@@ -23,17 +26,14 @@ import Data.Char ( isSpace )
import Haddock.Types( DocName, DocNameI )
import GHC.Utils.Exception
import GHC.Utils.FV as FV
import GHC.Utils.Outputable ( Outputable, panic, showPpr )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Unit.Module
import GHC.Driver.Types
import GHC
import GHC.Core.Class
import GHC.Driver.Session
import GHC.Core.Multiplicity
import GHC.Types.SrcLoc ( advanceSrcLoc )
import GHC.Types.Var ( Specificity, VarBndr(..), TyVarBinder
, tyVarKind, updateTyVarKind, isInvisibleArgFlag )
......@@ -50,6 +50,8 @@ import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import GHC.HsToCore.Docs
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
......@@ -89,25 +91,12 @@ ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust True = Just
ifTrueJust False = const Nothing
sigName :: LSig name -> [IdP name]
sigName :: LSig GhcRn -> [IdP GhcRn]
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?
isUserLSig :: LSig name -> Bool
isUserLSig (L _ (TypeSig {})) = True
isUserLSig (L _ (ClassOpSig {})) = True
isUserLSig (L _ (PatSynSig {})) = True
isUserLSig _ = False
isUserLSig :: forall p. UnXRec p => LSig p -> Bool
isUserLSig = isUserSig . unXRec @p
isClassD :: HsDecl a -> Bool
isClassD (TyClD _ d) = isClassDecl d
......@@ -258,18 +247,18 @@ data Precedence
--
-- 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 :(.
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
where
-- 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 _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)
go _ (HsSumTy x tys) = HsSumTy x (map reparenLType tys)
go _ (HsKindSig x ty kind) = HsKindSig x (reparenLType ty) (reparenLType kind)
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 _ (HsExplicitListTy x p tys) = HsExplicitListTy x p (map reparenLType tys)
go _ (HsExplicitTupleTy x tys) = HsExplicitTupleTy x (map reparenLType tys)
......@@ -278,7 +267,7 @@ reparenTypePrec = go
go p (HsForAllTy x tele ty)
= paren p PREC_CTX $ HsForAllTy x (reparenHsForAllTelescope tele) (reparenLType 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)
= paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)
go p (HsAppTy x fun_ty arg_ty)
......@@ -287,7 +276,7 @@ reparenTypePrec = go
= paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki)
go p (HsOpTy x ty1 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@HsStarTy{} = t
go _ t@HsSpliceTy{} = t
......@@ -296,43 +285,42 @@ reparenTypePrec = go
go _ t@XHsType{} = t
-- Located variant of 'go'
goL :: (XParTy a ~ NoExtField) => Precedence -> LHsType a -> LHsType a
goL ctxt_prec = fmap (go ctxt_prec)
goL :: Precedence -> LHsType a -> LHsType a
goL ctxt_prec = mapXRec @a (go ctxt_prec)
-- Optionally wrap a type in parens
paren :: (XParTy a ~ NoExtField)
=> Precedence -- Precedence of context
paren :: Precedence -- Precedence of context
-> Precedence -- Precedence of top-level operator
-> 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
-- | 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
-- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec')
reparenLType :: (XParTy a ~ NoExtField) => LHsType a -> LHsType a
reparenLType = fmap reparenType
reparenLType :: forall a. (XParTy a ~ NoExtField, MapXRec a, UnXRec a, WrapXRec a) => LHsType a -> LHsType a
reparenLType = mapXRec @a reparenType
-- | 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
reparenHsForAllTelescope (HsForAllVis x bndrs) =
HsForAllVis x (map (fmap reparenTyVar) bndrs)
HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope (HsForAllInvis x bndrs) =
HsForAllInvis x (map (fmap reparenTyVar) bndrs)
HsForAllInvis x (map (mapXRec @a reparenTyVar) bndrs)
reparenHsForAllTelescope v@XHsForAllTelescope{} = v
-- | 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 (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)
reparenTyVar v@XTyVarBndr{} = v
-- | 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 c@XConDeclField{} = c
......
......@@ -17,7 +17,6 @@ module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types
import Haddock.Convert
import Haddock.GhcUtils
import Control.Applicative ((<|>))
import Control.Arrow hiding ((<+>))
......
......@@ -34,7 +34,6 @@ import qualified Data.Map as M
import Data.Map (Map)
import Data.List
import Data.Maybe
import Control.Applicative
import Control.Monad
import Data.Traversable
......@@ -49,7 +48,6 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Unit.State
import GHC.Data.Bag
import GHC.Types.Name.Reader
import GHC.Tc.Types
import GHC.Data.FastString ( unpackFS, bytesFS )
......@@ -57,8 +55,6 @@ import GHC.Types.Basic ( StringLiteral(..), SourceText(..), PromotionFlag(..) )
import qualified GHC.Utils.Outputable as O
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Core.Multiplicity
-- | Use a 'TypecheckedModule' to produce an 'Interface'.
-- To do this, we need access to already processed modules in the topological
......@@ -240,7 +236,7 @@ mkAliasMap state mRenamedSource =
--
-- 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 =
M.map (map (unLoc . ideclName))
$ M.filter (all isInteresting) impModMap
......@@ -958,7 +954,7 @@ extractPatternSyn nm t tvs cons =
typ'' = noLoc (HsQualTy noExtField (noLoc []) 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
data_ty con
......
......@@ -474,7 +474,8 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
, con_mb_cxt = lcontext, con_args = details
, con_doc = mbldoc }) = do
, con_doc = mbldoc
, con_forall = forall }) = do
lname' <- renameL lname
ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext
......@@ -482,21 +483,24 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars
mbldoc' <- mapM renameLDocHsSyn mbldoc
return (decl { con_ext = noExtField, con_name = lname', con_ex_tvs = ltyvars'
, con_mb_cxt = lcontext'
, con_forall = forall -- Remove when #18311 is fixed
, 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_res_ty = res_ty
, con_doc = mbldoc }) = do
, con_res_ty = res_ty, con_forall = forall
, con_doc = mbldoc } = do
lnames' <- mapM renameL lnames
ltyvars' <- mapM renameLTyVarBndr ltyvars
lcontext' <- traverse renameLContext lcontext
details' <- renameDetails details
res_ty' <- renameLType res_ty
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_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)
-> RnM (HsScaled DocNameI (LHsType DocNameI))
......
......@@ -3,6 +3,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-}
module Haddock.Interface.Specialize
( specializeInstHead
......@@ -15,7 +16,6 @@ import Haddock.Types
import GHC
import GHC.Types.Name
import GHC.Data.FastString
import GHC.Builtin.Types.Prim ( funTyConName )
import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName )
import Control.Monad
......@@ -36,7 +36,7 @@ specialize specs = go spec_map0
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
strip_kind_sig :: HsType name -> HsType name
strip_kind_sig :: HsType GhcRn -> HsType GhcRn
strip_kind_sig (HsKindSig _ (L _ t) _) = t
strip_kind_sig typ = typ
......@@ -205,6 +205,7 @@ freeVariables :: HsType GhcRn -> Set Name
freeVariables =
everythingWithState Set.empty Set.union query
where
query :: forall a . Data a => a -> Set Name -> (Set Name, Set Name)
query term ctx = case cast term :: Maybe (HsType GhcRn) of
Just (HsForAllTy _ tele _) ->
(Set.empty, Set.union ctx (teleNames tele))
......@@ -213,6 +214,7 @@ freeVariables =
| otherwise -> (Set.singleton $ getName name, ctx)
_ -> (Set.empty, ctx)
teleNames :: HsForAllTelescope GhcRn -> Set Name
teleNames (HsForAllVis _ bndrs) = bndrsNames bndrs
teleNames (HsForAllInvis _ bndrs) = bndrsNames bndrs
......@@ -366,7 +368,6 @@ located :: Functor f => (a -> f b) -> Located a -> f (Located b)
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 (KindedTyVar _ _ (L _ name) _) = name
tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"
......@@ -669,7 +669,13 @@ instance MonadIO ErrMsgGhc where
-- * 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 XQualTy DocNameI = NoExtField
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Utils
......@@ -90,8 +91,6 @@ import qualified System.Posix.Internals
import GHC.Utils.Monad ( MonadIO(..) )
import GHC.Core.Multiplicity
--------------------------------------------------------------------------------
-- * Logging
......