diff options
| author | Zubin Duggal <zubin@cmi.ac.in> | 2022-03-12 00:07:56 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-03-23 13:39:39 -0400 |
| commit | b91798be48d9fa02610b419ccea15a7dfd663823 (patch) | |
| tree | fb87654ccd4a1e92e8c7a15bf454a867460869a3 | |
| parent | 52ffd38c610f418ee1d1a549cfdfdaa11794ea40 (diff) | |
| download | haskell-b91798be48d9fa02610b419ccea15a7dfd663823.tar.gz | |
hi haddock: Lex and store haddock docs in interface files
Names appearing in Haddock docstrings are lexed and renamed like any other names
appearing in the AST. We currently rename names irrespective of the namespace,
so both type and constructor names corresponding to an identifier will appear in
the docstring. Haddock will select a given name as the link destination based on
its own heuristics.
This patch also restricts the limitation of `-haddock` being incompatible with
`Opt_KeepRawTokenStream`.
The export and documenation structure is now computed in GHC and serialised in
.hi files. This can be used by haddock to directly generate doc pages without
reparsing or renaming the source. At the moment the operation of haddock
is not modified, that's left to a future patch.
Updates the haddock submodule with the minimum changes needed.
139 files changed, 8267 insertions, 1005 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 2d2de4550b..c62f4baa3b 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1171,7 +1171,7 @@ instance DesugaredMod DesugaredModule where type ParsedSource = Located HsModule type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString) + Maybe (LHsDoc GhcRn)) type TypecheckedSource = LHsBinds GhcTc -- NOTE: diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs index c577c46b75..a815c5e5bb 100644 --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -65,6 +65,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make import GHC.Types.Unique.FM +import GHC.Types.Unique.Map import GHC.Types.TyThing import GHC.Types.Unique ( isValidKnownKeyUnique ) @@ -80,7 +81,6 @@ import GHC.Data.List.SetOps import Control.Applicative ((<|>)) import Data.List ( intercalate , find ) import Data.Maybe -import qualified Data.Map as Map {- ************************************************************************ @@ -244,15 +244,15 @@ ghcPrimExports [ availTC n [n] [] | tc <- exposedPrimTyCons, let n = tyConName tc ] -ghcPrimDeclDocs :: DeclDocMap -ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs +ghcPrimDeclDocs :: Docs +ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs } where names = map idName ghcPrimIds ++ map idName allThePrimOpIds ++ map tyConName exposedPrimTyCons findName (nameStr, doc) | Just name <- find ((nameStr ==) . getOccString) names - = Just (name, mkHsDocString doc) + = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []]) | otherwise = Nothing {- diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs index 507d5243b9..1f1ff9ebc0 100644 --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -171,7 +171,7 @@ basicBlockCodeGen block = do -- ----------------------------------------------------------------------------- -- | Utilities ann :: SDoc -> Instr -> Instr -ann doc instr {- | debugIsOn -} = ANN doc instr +ann doc instr {- debugIsOn -} = ANN doc instr -- ann _ instr = instr {-# INLINE ann #-} @@ -199,7 +199,7 @@ ann doc instr {- | debugIsOn -} = ANN doc instr -- forced until we actually force them, and without -dppr-debug they should -- never end up being forced. annExpr :: CmmExpr -> Instr -> Instr -annExpr e instr {- | debugIsOn -} = ANN (text . show $ e) instr +annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr -- annExpr e instr {- | debugIsOn -} = ANN (pprExpr genericPlatform e) instr -- annExpr _ instr = instr {-# INLINE annExpr #-} diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 78ed3a104c..bfbd2000cb 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -16,7 +16,7 @@ module GHC.Core.FamInstEnv ( FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList, - famInstEnvElts, famInstEnvSize, familyInstances, + famInstEnvElts, famInstEnvSize, familyInstances, familyNameInstances, -- * CoAxioms mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, @@ -397,11 +397,15 @@ famInstEnvElts (FamIE _ rm) = elemsRM rm -- size. familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] -familyInstances (pkg_fie, home_fie) fam +familyInstances envs tc + = familyNameInstances envs (tyConName tc) + +familyNameInstances :: (FamInstEnv, FamInstEnv) -> Name -> [FamInst] +familyNameInstances (pkg_fie, home_fie) fam = get home_fie ++ get pkg_fie where get :: FamInstEnv -> [FamInst] - get (FamIE _ env) = lookupRM [RML_KnownTc (tyConName fam)] env + get (FamIE _ env) = lookupRM [RML_KnownTc fam] env -- | Makes no particular effort to detect conflicts. diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index e223a7cd87..63dde6f6b5 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -27,6 +27,7 @@ module GHC.Core.InstEnv ( memberInstEnv, instIsVisible, classInstances, instanceBindFun, + classNameInstances, instanceCantMatch, roughMatchTcs, isOverlappable, isOverlapping, isIncoherent ) where @@ -435,8 +436,8 @@ instEnvElts :: InstEnv -> [ClsInst] instEnvElts (InstEnv rm) = elemsRM rm -- See Note [InstEnv determinism] -instEnvEltsForClass :: InstEnv -> Class -> [ClsInst] -instEnvEltsForClass (InstEnv rm) cls = lookupRM [RML_KnownTc (className cls)] rm +instEnvEltsForClass :: InstEnv -> Name -> [ClsInst] +instEnvEltsForClass (InstEnv rm) cls_nm = lookupRM [RML_KnownTc cls_nm] rm -- N.B. this is not particularly efficient but used only by GHCi. instEnvClasses :: InstEnv -> UniqDSet Class @@ -457,7 +458,10 @@ instIsVisible vis_mods ispec | otherwise -> True classInstances :: InstEnvs -> Class -> [ClsInst] -classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls +classInstances envs cls = classNameInstances envs (className cls) + +classNameInstances :: InstEnvs -> Name -> [ClsInst] +classNameInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls = get home_ie ++ get pkg_ie where get :: InstEnv -> [ClsInst] diff --git a/compiler/GHC/Data/EnumSet.hs b/compiler/GHC/Data/EnumSet.hs index a7949c7e71..d364dc05d7 100644 --- a/compiler/GHC/Data/EnumSet.hs +++ b/compiler/GHC/Data/EnumSet.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' -- things. module GHC.Data.EnumSet @@ -12,10 +14,12 @@ module GHC.Data.EnumSet ) where import GHC.Prelude +import GHC.Utils.Binary import qualified Data.IntSet as IntSet newtype EnumSet a = EnumSet IntSet.IntSet + deriving (Semigroup, Monoid) member :: Enum a => a -> EnumSet a -> Bool member x (EnumSet s) = IntSet.member (fromEnum x) s @@ -37,3 +41,30 @@ empty = EnumSet IntSet.empty difference :: EnumSet a -> EnumSet a -> EnumSet a difference (EnumSet a) (EnumSet b) = EnumSet (IntSet.difference a b) + +-- | Represents the 'EnumSet' as a bit set. +-- +-- Assumes that all elements are non-negative. +-- +-- This is only efficient for values that are sufficiently small, +-- for example in the lower hundreds. +instance Binary (EnumSet a) where + put_ bh = put_ bh . enumSetToBitArray + get bh = bitArrayToEnumSet <$> get bh + +-- TODO: Using 'Natural' instead of 'Integer' should be slightly more efficient +-- but we don't currently have a 'Binary' instance for 'Natural'. +type BitArray = Integer + +enumSetToBitArray :: EnumSet a -> BitArray +enumSetToBitArray (EnumSet int_set) = + IntSet.foldl' setBit 0 int_set + +bitArrayToEnumSet :: BitArray -> EnumSet a +bitArrayToEnumSet ba = EnumSet (go (popCount ba) 0 IntSet.empty) + where + go 0 _ !int_set = int_set + go n i !int_set = + if ba `testBit` i + then go (pred n) (succ i) (IntSet.insert i int_set) + else go n (succ i) int_set diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs index 03d720eb37..e6dcb14b6b 100644 --- a/compiler/GHC/Data/StringBuffer.hs +++ b/compiler/GHC/Data/StringBuffer.hs @@ -26,6 +26,7 @@ module GHC.Data.StringBuffer hPutStringBuffer, appendStringBuffers, stringToStringBuffer, + stringBufferFromByteString, -- * Inspection nextChar, @@ -68,6 +69,10 @@ import System.IO.Unsafe ( unsafePerformIO ) import GHC.IO.Encoding.UTF8 ( mkUTF8 ) import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString as BS +import Data.ByteString ( ByteString ) + import GHC.Exts import Foreign @@ -199,6 +204,15 @@ stringToStringBuffer str = -- sentinels for UTF-8 decoding return (StringBuffer buf size 0) +-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really +-- relies on the internals of both 'ByteString' and 'StringBuffer'. +-- +-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood) +stringBufferFromByteString :: ByteString -> StringBuffer +stringBufferFromByteString bs = + let BS.PS fp off len = BS.append bs (BS.pack [0,0,0]) + in StringBuffer { buf = fp, len = len - 3, cur = off } + -- ----------------------------------------------------------------------------- -- Grab a character diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 1d1222fbab..a2ac1b75f4 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -21,19 +21,23 @@ where import GHC.Prelude import GHC.Utils.Outputable +import GHC.Utils.Binary import GHC.Data.EnumSet as EnumSet import Control.Monad (guard) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe,mapMaybe) - data Language = Haskell98 | Haskell2010 | GHC2021 deriving (Eq, Enum, Show, Bounded) instance Outputable Language where ppr = text . show +instance Binary Language where + put_ bh = put_ bh . fromEnum + get bh = toEnum <$> get bh + -- | Debugging flags data DumpFlag -- See Note [Updating flag description in the User's Guide] diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 0045588eaf..b0eb32b380 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -96,7 +96,7 @@ data HsModule -- downstream. hsmodDecls :: [LHsDecl GhcPs], -- ^ Type, class, value, and interface signature decls - hsmodDeprecMessage :: Maybe (LocatedP WarningTxt), + hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)), -- ^ reason\/explanation for warning/deprecation of this module -- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' @@ -104,7 +104,7 @@ data HsModule -- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - hsmodHaddockModHeader :: Maybe LHsDocString + hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs) -- ^ Haddock module info and description, unparsed -- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' @@ -133,13 +133,13 @@ data AnnsModule instance Outputable HsModule where ppr (HsModule _ _ Nothing _ imports decls _ mbDoc) - = pp_mb mbDoc $$ pp_nonnull imports - $$ pp_nonnull decls + = pprMaybeWithDoc mbDoc $ pp_nonnull imports + $$ pp_nonnull decls ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc) - = vcat [ - pp_mb mbDoc, - case exports of + = pprMaybeWithDoc mbDoc $ + vcat + [ case exports of Nothing -> pp_header (text "where") Just es -> vcat [ pp_header lparen, @@ -156,10 +156,6 @@ instance Outputable HsModule where 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/Decls.hs b/compiler/GHC/Hs/Decls.hs index 40c54b629a..568783bdb5 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -686,8 +686,8 @@ pprConDecl (ConDeclH98 { con_name = L _ con , con_mb_cxt = mcxt , con_args = args , con_doc = doc }) - = sep [ ppr_mbDoc doc - , pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt + = pprMaybeWithDoc doc $ + sep [ pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt , ppr_details args ] where -- In ppr_details: let's not print the multiplicities (they are always 1, by @@ -703,7 +703,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) - = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon + = pprMaybeWithDoc doc $ ppr_con_names cons <+> dcolon <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt, sep (ppr_args args ++ [ppr res_ty]) ]) where @@ -1172,7 +1172,7 @@ type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno DocDecl = SrcSpanAnnA +type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA type instance Anno OverlapMode = SrcSpanAnnP type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 117ce3adad..91f584c8d9 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -1,161 +1,288 @@ - +-- | Types and functions for raw and lexed docstrings. {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} module GHC.Hs.Doc - ( HsDocString - , LHsDocString - , mkHsDocString - , mkHsDocStringUtf8ByteString - , isEmptyDocString - , unpackHDS - , hsDocStringToByteString - , ppr_mbDoc + ( HsDoc + , WithHsDocIdentifiers(..) + , hsDocIds + , LHsDoc + , pprHsDocDebug + , pprWithDoc + , pprMaybeWithDoc - , appendDocs - , concatDocs + , module GHC.Hs.DocString - , DeclDocMap(..) - , emptyDeclDocMap + , ExtractedTHDocs(..) - , ArgDocMap(..) - , emptyArgDocMap + , DocStructureItem(..) + , DocStructure - , ExtractedTHDocs(..) + , Docs(..) + , emptyDocs ) where import GHC.Prelude import GHC.Utils.Binary -import GHC.Utils.Encoding import GHC.Types.Name -import GHC.Utils.Outputable as Outputable +import GHC.Utils.Outputable as Outputable hiding ((<>)) import GHC.Types.SrcLoc +import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.EnumSet (EnumSet) +import GHC.Types.Avail +import GHC.Types.Name.Set +import GHC.Unit.Module.Name +import GHC.Driver.Flags -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C8 +import Control.Applicative (liftA2) import Data.Data import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.LanguageExtensions.Type +import qualified GHC.Utils.Outputable as O +import Language.Haskell.Syntax.Extension +import GHC.Hs.Extension +import GHC.Types.Unique.Map +import Data.List (sortBy) + +import GHC.Hs.DocString --- | Haskell Documentation String +-- | A docstring with the (probable) identifiers found in it. +type HsDoc = WithHsDocIdentifiers HsDocString + +-- | Annotate a value with the probable identifiers found in it +-- These will be used by haddock to generate links. +-- +-- The identifiers are bundled along with their location in the source file. +-- This is useful for tooling to know exactly where they originate. -- --- 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) +-- This type is currently used in two places - for regular documentation comments, +-- with 'a' set to 'HsDocString', and for adding identifier information to +-- warnings, where 'a' is 'StringLiteral' +data WithHsDocIdentifiers a pass = WithHsDocIdentifiers + { hsDocString :: !a + , hsDocIdentifiers :: ![Located (IdP pass)] + } --- | Located Haskell Documentation String -type LHsDocString = Located HsDocString +deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass) +deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) -instance Binary HsDocString where - put_ bh (HsDocString bs) = put_ bh bs - get bh = HsDocString <$> get bh +-- | For compatibility with the existing @-ddump-parsed' output, we only show +-- the docstring. +-- +-- Use 'pprHsDoc' to show `HsDoc`'s internals. +instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where + ppr (WithHsDocIdentifiers s _ids) = ppr s -instance Outputable HsDocString where - ppr = doubleQuotes . text . unpackHDS +instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where + put_ bh (WithHsDocIdentifiers s ids) = do + put_ bh s + put_ bh ids + get bh = + liftA2 WithHsDocIdentifiers (get bh) (get bh) -isEmptyDocString :: HsDocString -> Bool -isEmptyDocString (HsDocString bs) = BS.null bs +-- | Extract a mapping from the lexed identifiers to the names they may +-- correspond to. +hsDocIds :: WithHsDocIdentifiers a GhcRn -> NameSet +hsDocIds (WithHsDocIdentifiers _ ids) = mkNameSet $ map unLoc ids -mkHsDocString :: String -> HsDocString -mkHsDocString s = HsDocString (utf8EncodeString s) +-- | Pretty print a thing with its doc +-- The docstring will include the comment decorators '-- |', '{-|' etc +-- and will come either before or after depending on how it was written +-- i.e it will come after the thing if it is a '-- ^' or '{-^' and before +-- otherwise. +pprWithDoc :: LHsDoc name -> SDoc -> SDoc +pprWithDoc doc = pprWithDocString (hsDocString $ unLoc doc) --- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. -mkHsDocStringUtf8ByteString :: ByteString -> HsDocString -mkHsDocStringUtf8ByteString = HsDocString +-- | See 'pprWithHsDoc' +pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc +pprMaybeWithDoc Nothing = id +pprMaybeWithDoc (Just doc) = pprWithDoc doc -unpackHDS :: HsDocString -> String -unpackHDS = utf8DecodeByteString . hsDocStringToByteString +-- | Print a doc with its identifiers, useful for debugging +pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc +pprHsDocDebug (WithHsDocIdentifiers s ids) = + vcat [ text "text:" $$ nest 2 (pprHsDocString s) + , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids)) + ] --- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'. -hsDocStringToByteString :: HsDocString -> ByteString -hsDocStringToByteString (HsDocString bs) = bs +type LHsDoc pass = Located (HsDoc pass) -ppr_mbDoc :: Maybe LHsDocString -> SDoc -ppr_mbDoc (Just doc) = ppr doc -ppr_mbDoc Nothing = empty +-- | A simplified version of 'HsImpExp.IE'. +data DocStructureItem + = DsiSectionHeading Int (HsDoc GhcRn) + | DsiDocChunk (HsDoc GhcRn) + | DsiNamedChunkRef String + | DsiExports Avails + | DsiModExport + (NonEmpty ModuleName) -- ^ We might re-export avails from multiple + -- modules with a single export declaration. E.g. + -- when we have + -- + -- > module M (module X) where + -- > import R0 as X + -- > import R1 as X + Avails --- | 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) +instance Binary DocStructureItem where + put_ bh = \case + DsiSectionHeading level doc -> do + putByte bh 0 + put_ bh level + put_ bh doc + DsiDocChunk doc -> do + putByte bh 1 + put_ bh doc + DsiNamedChunkRef name -> do + putByte bh 2 + put_ bh name + DsiExports avails -> do + putByte bh 3 + put_ bh avails + DsiModExport mod_names avails -> do + putByte bh 4 + put_ bh mod_names + put_ bh avails + + get bh = do + tag <- getByte bh + case tag of + 0 -> DsiSectionHeading <$> get bh <*> get bh + 1 -> DsiDocChunk <$> get bh + 2 -> DsiNamedChunkRef <$> get bh + 3 -> DsiExports <$> get bh + 4 -> DsiModExport <$> get bh <*> get bh + _ -> fail "instance Binary DocStructureItem: Invalid tag" + +instance Outputable DocStructureItem where + ppr = \case + DsiSectionHeading level doc -> vcat + [ text "section heading, level" <+> ppr level O.<> colon + , nest 2 (pprHsDocDebug doc) + ] + DsiDocChunk doc -> vcat + [ text "documentation chunk:" + , nest 2 (pprHsDocDebug doc) + ] + DsiNamedChunkRef name -> + text "reference to named chunk:" <+> text name + DsiExports avails -> + text "avails:" $$ nest 2 (ppr avails) + DsiModExport mod_names avails -> + text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails) -emptyDeclDocMap :: DeclDocMap -emptyDeclDocMap = DeclDocMap Map.empty +type DocStructure = [DocStructureItem] --- | Docs for arguments. E.g. function arguments, method arguments. -newtype ArgDocMap = ArgDocMap (Map Name (IntMap HsDocString)) +data Docs = Docs + { docs_mod_hdr :: Maybe (HsDoc GhcRn) + -- ^ Module header. + , docs_decls :: UniqMap Name [HsDoc GhcRn] + -- ^ Docs for declarations: functions, data types, instances, methods etc. + -- A list because sometimes subsequent haddock comments can be combined into one + , docs_args :: UniqMap Name (IntMap (HsDoc GhcRn)) + -- ^ Docs for arguments. E.g. function arguments, method arguments. + , docs_structure :: DocStructure + , docs_named_chunks :: Map String (HsDoc GhcRn) + -- ^ Map from chunk name to content. + -- + -- This map will be empty unless we have an explicit export list from which + -- we can reference the chunks. + , docs_haddock_opts :: Maybe String + -- ^ Haddock options from @OPTIONS_HADDOCK@ or from @-haddock-opts@. + , docs_language :: Maybe Language + -- ^ The 'Language' used in the module, for example 'Haskell2010'. + , docs_extensions :: EnumSet Extension + -- ^ The full set of language extensions used in the module. + } -instance Binary ArgDocMap where - put_ bh (ArgDocMap m) = put_ bh (Map.toList (IntMap.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 IntMap.fromDistinctAscList . Map.fromList <$> get bh +instance Binary Docs where + put_ bh docs = do + put_ bh (docs_mod_hdr docs) + put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_decls docs) + put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_args docs) + put_ bh (docs_structure docs) + put_ bh (Map.toList $ docs_named_chunks docs) + put_ bh (docs_haddock_opts docs) + put_ bh (docs_language docs) + put_ bh (docs_extensions docs) + get bh = do + mod_hdr <- get bh + decls <- listToUniqMap <$> get bh + args <- listToUniqMap <$> get bh + structure <- get bh + named_chunks <- Map.fromList <$> get bh + haddock_opts <- get bh + language <- get bh + exts <- get bh + pure Docs { docs_mod_hdr = mod_hdr + , docs_decls = decls + , docs_args = args + , docs_structure = structure + , docs_named_chunks = named_chunks + , docs_haddock_opts = haddock_opts + , docs_language = language + , docs_extensions = exts + } -instance Outputable ArgDocMap where - ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) +instance Outputable Docs where + ppr docs = + vcat + [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr + , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls + , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args + , pprField (vcat . map ppr) "documentation structure" docs_structure + , pprField (pprMap (doubleQuotes . text) pprHsDocDebug) "named chunks" + docs_named_chunks + , pprField pprMbString "haddock options" docs_haddock_opts + , pprField ppr "language" docs_language + , pprField (vcat . map ppr . EnumSet.toList) "language extensions" + docs_extensions + ] where - pprPair (name, int_map) = - ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map) - pprIntMap im = vcat (map pprIPair (IntMap.toAscList im)) - pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) + pprField :: (a -> SDoc) -> String -> (Docs -> a) -> SDoc + pprField ppr' heading lbl = + text heading O.<> colon $$ nest 2 (ppr' (lbl docs)) + pprMap pprKey pprVal m = + vcat $ flip map (Map.toList m) $ \(k, v) -> + pprKey k O.<> colon $$ nest 2 (pprVal v) + pprIntMap pprKey pprVal m = + vcat $ flip map (IntMap.toList m) $ \(k, v) -> + pprKey k O.<> colon $$ nest 2 (pprVal v) + pprMbString Nothing = empty + pprMbString (Just s) = text s + pprMaybe ppr' = \case + Nothing -> text "Nothing" + Just x -> text "Just" <+> ppr' x -emptyArgDocMap :: ArgDocMap -emptyArgDocMap = ArgDocMap Map.empty +emptyDocs :: Docs +emptyDocs = Docs + { docs_mod_hdr = Nothing + , docs_decls = emptyUniqMap + , docs_args = emptyUniqMap + , docs_structure = [] + , docs_named_chunks = Map.empty + , docs_haddock_opts = Nothing + , docs_language = Nothing + , docs_extensions = EnumSet.empty + } -- | Maps of docs that were added via Template Haskell's @putDoc@. data ExtractedTHDocs = ExtractedTHDocs - { ethd_mod_header :: Maybe HsDocString + { ethd_mod_header :: Maybe (HsDoc GhcRn) -- ^ The added module header documentation, if it exists. - , ethd_decl_docs :: DeclDocMap + , ethd_decl_docs :: UniqMap Name (HsDoc GhcRn) -- ^ The documentation added to declarations. - , ethd_arg_docs :: ArgDocMap + , ethd_arg_docs :: UniqMap Name (IntMap (HsDoc GhcRn)) -- ^ The documentation added to function arguments. - , ethd_inst_docs :: DeclDocMap + , ethd_inst_docs :: UniqMap Name (HsDoc GhcRn) -- ^ The documentation added to class and family instances. } diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs new file mode 100644 index 0000000000..3a557ee0e8 --- /dev/null +++ b/compiler/GHC/Hs/DocString.hs @@ -0,0 +1,197 @@ +-- | An exactprintable structure for docstrings +{-# LANGUAGE DeriveDataTypeable #-} + +module GHC.Hs.DocString + ( LHsDocString + , HsDocString(..) + , HsDocStringDecorator(..) + , HsDocStringChunk(..) + , LHsDocStringChunk + , isEmptyDocString + , unpackHDSC + , mkHsDocStringChunk + , mkHsDocStringChunkUtf8ByteString + , pprHsDocString + , pprHsDocStrings + , mkGeneratedHsDocString + , docStringChunks + , renderHsDocString + , renderHsDocStrings + , exactPrintHsDocString + , pprWithDocString + ) where + +import GHC.Prelude + +import GHC.Utils.Binary +import GHC.Utils.Encoding +import GHC.Utils.Outputable as Outputable hiding ((<>)) +import GHC.Types.SrcLoc + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Data +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (intercalate) + +type LHsDocString = Located HsDocString + +-- | Haskell Documentation String +-- +-- Rich structure to support exact printing +-- The location around each chunk doesn't include the decorators +data HsDocString + = MultiLineDocString !HsDocStringDecorator !(NonEmpty LHsDocStringChunk) + -- ^ The first chunk is preceded by "-- <decorator>" and each following chunk is preceded by "--" + -- Example: -- | This is a docstring for 'foo'. It is the line with the decorator '|' and is always included + -- -- This continues that docstring and is the second element in the NonEmpty list + -- foo :: a -> a + | NestedDocString !HsDocStringDecorator LHsDocStringChunk + -- ^ The docstring is preceded by "{-<decorator>" and followed by "-}" + -- The chunk contains balanced pairs of '{-' and '-}' + | GeneratedDocString HsDocStringChunk + -- ^ A docstring generated either internally or via TH + -- Pretty printed with the '-- |' decorator + -- This is because it may contain unbalanced pairs of '{-' and '-}' and + -- not form a valid 'NestedDocString' + deriving (Eq, Data, Show) + +instance Outputable HsDocString where + ppr = text . renderHsDocString + +-- | Annotate a pretty printed thing with its doc +-- The docstring comes after if is 'HsDocStringPrevious' +-- Otherwise it comes before. +-- Note - we convert MultiLineDocString HsDocStringPrevious to HsDocStringNext +-- because we can't control if something else will be pretty printed on the same line +pprWithDocString :: HsDocString -> SDoc -> SDoc +pprWithDocString (MultiLineDocString HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString HsDocStringNext ds) sd +pprWithDocString doc@(NestedDocString HsDocStringPrevious _) sd = sd <+> pprHsDocString doc +pprWithDocString doc sd = pprHsDocString doc $+$ sd + + +instance Binary HsDocString where + put_ bh x = case x of + MultiLineDocString dec xs -> do + putByte bh 0 + put_ bh dec + put_ bh xs + NestedDocString dec x -> do + putByte bh 1 + put_ bh dec + put_ bh x + GeneratedDocString x -> do + putByte bh 2 + put_ bh x + get bh = do + tag <- getByte bh + case tag of + 0 -> MultiLineDocString <$> get bh <*> get bh + 1 -> NestedDocString <$> get bh <*> get bh + 2 -> GeneratedDocString <$> get bh + t -> fail $ "HsDocString: invalid tag " ++ show t + +data HsDocStringDecorator + = HsDocStringNext -- ^ '|' is the decorator + | HsDocStringPrevious -- ^ '^' is the decorator + | HsDocStringNamed !String -- ^ '$<string>' is the decorator + | HsDocStringGroup !Int -- ^ The decorator is the given number of '*'s + deriving (Eq, Ord, Show, Data) + +instance Outputable HsDocStringDecorator where + ppr = text . printDecorator + +printDecorator :: HsDocStringDecorator -> String +printDecorator HsDocStringNext = "|" +printDecorator HsDocStringPrevious = "^" +printDecorator (HsDocStringNamed n) = '$':n +printDecorator (HsDocStringGroup n) = replicate n '*' + +instance Binary HsDocStringDecorator where + put_ bh x = case x of + HsDocStringNext -> putByte bh 0 + HsDocStringPrevious -> putByte bh 1 + HsDocStringNamed n -> putByte bh 2 >> put_ bh n + HsDocStringGroup n -> putByte bh 3 >> put_ bh n + get bh = do + tag <- getByte bh + case tag of + 0 -> pure HsDocStringNext + 1 -> pure HsDocStringPrevious + 2 -> HsDocStringNamed <$> get bh + 3 -> HsDocStringGroup <$> get bh + t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t + +type LHsDocStringChunk = Located HsDocStringChunk + +-- | A continguous chunk of documentation +newtype HsDocStringChunk = HsDocStringChunk ByteString + deriving (Eq,Ord,Data, Show) + +instance Binary HsDocStringChunk where + put_ bh (HsDocStringChunk bs) = put_ bh bs + get bh = HsDocStringChunk <$> get bh + +instance Outputable HsDocStringChunk where + ppr = text . unpackHDSC + + +mkHsDocStringChunk :: String -> HsDocStringChunk +mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeString s) + +-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. +mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk +mkHsDocStringChunkUtf8ByteString = HsDocStringChunk + +unpackHDSC :: HsDocStringChunk -> String +unpackHDSC (HsDocStringChunk bs) = utf8DecodeByteString bs + +nullHDSC :: HsDocStringChunk -> Bool +nullHDSC (HsDocStringChunk bs) = BS.null bs + +mkGeneratedHsDocString :: String -> HsDocString +mkGeneratedHsDocString = GeneratedDocString . mkHsDocStringChunk + +isEmptyDocString :: HsDocString -> Bool +isEmptyDocString (MultiLineDocString _ xs) = all (nullHDSC . unLoc) xs +isEmptyDocString (NestedDocString _ s) = nullHDSC $ unLoc s +isEmptyDocString (GeneratedDocString x) = nullHDSC x + +docStringChunks :: HsDocString -> [LHsDocStringChunk] +docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs +docStringChunks (NestedDocString _ x) = [x] +docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x] + +-- | Pretty print with decorators, exactly as the user wrote it +pprHsDocString :: HsDocString -> SDoc +pprHsDocString = text . exactPrintHsDocString + +pprHsDocStrings :: [HsDocString] -> SDoc +pprHsDocStrings = text . intercalate "\n\n" . map exactPrintHsDocString + +-- | Pretty print with decorators, exactly as the user wrote it +exactPrintHsDocString :: HsDocString -> String +exactPrintHsDocString (MultiLineDocString dec (x :| xs)) + = unlines' $ ("-- " ++ printDecorator dec ++ unpackHDSC (unLoc x)) + : map (\x -> "--" ++ unpackHDSC (unLoc x)) xs +exactPrintHsDocString (NestedDocString dec (L _ s)) + = "{-" ++ printDecorator dec ++ unpackHDSC s ++ "-}" +exactPrintHsDocString (GeneratedDocString x) = case lines (unpackHDSC x) of + [] -> "" + (x:xs) -> unlines' $ ( "-- |" ++ x) + : map (\y -> "--"++y) xs + +-- | Just get the docstring, without any decorators +renderHsDocString :: HsDocString -> String +renderHsDocString (MultiLineDocString _ (x :| xs)) = unlines' $ map (unpackHDSC . unLoc) (x:xs) +renderHsDocString (NestedDocString _ ds) = unpackHDSC $ unLoc ds +renderHsDocString (GeneratedDocString x) = unpackHDSC x + +-- | Don't add a newline to a single string +unlines' :: [String] -> String +unlines' = intercalate "\n" + +-- | Just get the docstring, without any decorators +-- Seperates docstrings using "\n\n", which is how haddock likes to render them +renderHsDocStrings :: [HsDocString] -> String +renderHsDocStrings = intercalate "\n\n" . map renderHsDocString diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index fa16da9fdc..22c83e6e2a 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -19,7 +19,7 @@ module GHC.Hs.ImpExp where import GHC.Prelude import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) -import GHC.Hs.Doc ( HsDocString ) +import GHC.Hs.Doc import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.FieldLabel ( FieldLabel ) @@ -279,8 +279,8 @@ data IE pass -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading - | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation + | IEGroup (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading + | IEDoc (XIEDoc pass) (LHsDoc pass) -- ^ Some documentation | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc | XIE !(XXIE pass) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 2b17df420e..40dc281a74 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1005,7 +1005,7 @@ 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 + = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty) ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc ppr_names [n] = pprPrefixOcc n @@ -1094,10 +1094,7 @@ ppr_mono_ty (HsParTy _ ty) -- 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 + = pprWithDoc doc $ ppr_mono_lty ty ppr_mono_ty (XHsType t) = ppr t diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 78d43b164f..b95a5aebbe 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -225,7 +225,7 @@ deSugar hsc_env ; foreign_files <- readIORef th_foreign_files_var - ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env + ; docs <- extractDocs dflags tcg_env ; let mod_guts = ModGuts { mg_module = mod, @@ -255,9 +255,7 @@ deSugar hsc_env mg_safe_haskell = safe_mode, mg_trust_pkg = imp_trust_own_pkg imports, mg_complete_matches = complete_matches, - mg_doc_hdr = doc_hdr, - mg_decl_docs = decl_docs, - mg_arg_docs = arg_docs + mg_docs = docs } ; return (msgs, Just mod_guts) }}}} diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 15771cd26e..c4839ae449 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -8,8 +8,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.HsToCore.Docs where import GHC.Prelude @@ -32,89 +30,237 @@ import Control.Monad.IO.Class import Data.Bifunctor (first) import Data.IntMap (IntMap) import qualified Data.IntMap as IM -import Data.Map (Map) +import Data.Map.Strict (Map) import qualified Data.Map as M +import qualified Data.Set as Set import Data.Maybe import Data.Semigroup import GHC.IORef (readIORef) +import GHC.Unit.Types +import GHC.Hs +import GHC.Types.Avail +import GHC.Unit.Module +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Unit.Module.Imported +import GHC.Driver.Session +import GHC.Types.TypeEnv +import GHC.Types.Id +import GHC.Types.Unique.Map -- | Extract docs from renamer output. -- This is monadic since we need to be able to read documentation added from -- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'. extractDocs :: MonadIO m - => TcGblEnv - -> m (Maybe HsDocString, DeclDocMap, ArgDocMap) + => DynFlags -> TcGblEnv + -> m (Maybe Docs) -- ^ -- 1. Module header -- 2. Docs on top level declarations -- 3. Docs on arguments -extractDocs TcGblEnv { tcg_semantic_mod = mod - , tcg_rn_decls = mb_rn_decls - , tcg_insts = insts - , tcg_fam_insts = fam_insts - , tcg_doc_hdr = mb_doc_hdr - , tcg_th_docs = th_docs_var - } = do +extractDocs dflags + TcGblEnv { tcg_semantic_mod = semantic_mdl + , tcg_mod = mdl + , tcg_rn_decls = Just rn_decls + , tcg_rn_exports = mb_rn_exports + , tcg_exports = all_exports + , tcg_imports = import_avails + , tcg_insts = insts + , tcg_fam_insts = fam_insts + , tcg_doc_hdr = mb_doc_hdr + , tcg_th_docs = th_docs_var + , tcg_type_env = ty_env + } = do th_docs <- liftIO $ readIORef th_docs_var - let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr) - ExtractedTHDocs - th_doc_hdr - (DeclDocMap th_doc_map) - (ArgDocMap th_arg_map) - (DeclDocMap th_inst_map) = extractTHDocs th_docs - return - ( doc_hdr - , DeclDocMap (th_doc_map <> th_inst_map <> doc_map) - , ArgDocMap (th_arg_map `unionArgMaps` arg_map) - ) + let doc_hdr = (unLoc <$> mb_doc_hdr) + ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs + mod_docs + = Docs + { docs_mod_hdr = th_hdr <|> doc_hdr + -- Left biased union (see #21220) + , docs_decls = plusUniqMap_C (\a _ -> a) + ((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs) + -- These will not clash so safe to use plusUniqMap + doc_map + , docs_args = th_arg_docs `unionArgMaps` arg_map + , docs_structure = doc_structure + , docs_named_chunks = named_chunks + , docs_haddock_opts = haddockOptions dflags + , docs_language = language_ + , docs_extensions = exts + } + pure (Just mod_docs) where - (doc_map, arg_map) = maybe (M.empty, M.empty) - (mkMaps local_insts) - mb_decls_with_docs - mb_decls_with_docs = topDecls <$> mb_rn_decls - local_insts = filter (nameIsLocalOrFrom mod) + exts = extensionFlags dflags + language_ = language dflags + + -- We need to lookup the Names for default methods, so we + -- can put them in the correct map + -- See Note [default method Name] in GHC.Iface.Recomp + def_meths_env = mkOccEnv [(occ, nm) + | id <- typeEnvIds ty_env + , let nm = idName id + occ = nameOccName nm + , isDefaultMethodOcc occ + ] + + (doc_map, arg_map) = mkMaps def_meths_env local_insts decls_with_docs + decls_with_docs = topDecls rn_decls + local_insts = filter (nameIsLocalOrFrom semantic_mdl) $ map getName insts ++ map getName fam_insts + doc_structure = mkDocStructure mdl import_avails mb_rn_exports rn_decls + all_exports def_meths_env + named_chunks = getNamedChunks (isJust mb_rn_exports) rn_decls +extractDocs _ _ = pure Nothing + +-- | If we have an explicit export list, we extract the documentation structure +-- from that. +-- Otherwise we use the renamed exports and declarations. +mkDocStructure :: Module -- ^ The current module + -> ImportAvails -- ^ Imports + -> Maybe [(LIE GhcRn, Avails)] -- ^ Explicit export list + -> HsGroup GhcRn + -> [AvailInfo] -- ^ All exports + -> OccEnv Name -- ^ Default Methods + -> DocStructure +mkDocStructure mdl import_avails (Just export_list) _ _ _ = + mkDocStructureFromExportList mdl import_avails export_list +mkDocStructure _ _ Nothing rn_decls all_exports def_meths_env = + mkDocStructureFromDecls def_meths_env all_exports rn_decls + +-- TODO: +-- * Maybe remove items that export nothing? +-- * Combine sequences of DsiExports? +-- * Check the ordering of avails in DsiModExport +mkDocStructureFromExportList + :: Module -- ^ The current module + -> ImportAvails + -> [(LIE GhcRn, Avails)] -- ^ Explicit export list + -> DocStructure +mkDocStructureFromExportList mdl import_avails export_list = + toDocStructure . first unLoc <$> export_list + where + toDocStructure :: (IE GhcRn, Avails) -> DocStructureItem + toDocStructure = \case + (IEModuleContents _ lmn, avails) -> moduleExport (unLoc lmn) avails + (IEGroup _ level doc, _) -> DsiSectionHeading level (unLoc doc) + (IEDoc _ doc, _) -> DsiDocChunk (unLoc doc) + (IEDocNamed _ name, _) -> DsiNamedChunkRef name + (_, avails) -> DsiExports (nubAvails avails) + + moduleExport :: ModuleName -- Alias + -> Avails + -> DocStructureItem + moduleExport alias avails = + DsiModExport (nubSortNE orig_names) (nubAvails avails) + where + orig_names = M.findWithDefault aliasErr alias aliasMap + aliasErr = error $ "mkDocStructureFromExportList: " + ++ (moduleNameString . moduleName) mdl + ++ ": Can't find alias " ++ moduleNameString alias + nubSortNE = NonEmpty.fromList . + Set.toList . + Set.fromList . + NonEmpty.toList + + -- Map from aliases to true module names. + aliasMap :: Map ModuleName (NonEmpty ModuleName) + aliasMap = + M.fromListWith (<>) $ + (this_mdl_name, this_mdl_name :| []) + : (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) -> + [(imv_name imv, moduleName mdl :| []) | imv <- imvs]) + where + this_mdl_name = moduleName mdl + + imported :: ModuleEnv [ImportedModsVal] + imported = mapModuleEnv importedByUser (imp_mods import_avails) + +-- | Figure out the documentation structure by correlating +-- the module exports with the located declarations. +mkDocStructureFromDecls :: OccEnv Name -- ^ The default method environment + -> [AvailInfo] -- ^ All exports, unordered + -> HsGroup GhcRn + -> DocStructure +mkDocStructureFromDecls env all_exports decls = + map unLoc (sortLocated (docs ++ avails)) + where + avails :: [Located DocStructureItem] + avails = flip fmap all_exports $ \avail -> + case M.lookup (availName avail) name_locs of + Just loc -> L loc (DsiExports [avail]) + -- FIXME: This is just a workaround that we use when handling e.g. + -- associated data families like in the html-test Instances.hs. + Nothing -> noLoc (DsiExports [avail]) + -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for" + -- (ppr avail) + + docs = mapMaybe structuralDoc (hs_docs decls) + + structuralDoc :: LDocDecl GhcRn + -> Maybe (Located DocStructureItem) + structuralDoc = \case + L loc (DocCommentNamed _name doc) -> + -- TODO: Is this correct? + -- NB: There is no export list where we could reference the named chunk. + Just (L (locA loc) (DsiDocChunk (unLoc doc))) + + L loc (DocGroup level doc) -> + Just (L (locA loc) (DsiSectionHeading level (unLoc doc))) + + _ -> Nothing + + name_locs = M.fromList (concatMap ldeclNames (ungroup decls)) + ldeclNames (L loc d) = zip (getMainDeclBinder env d) (repeat (locA loc)) + +-- | Extract named documentation chunks from the renamed declarations. +-- +-- If there is no explicit export list, we simply return an empty map +-- since there would be no way to link to a named chunk. +getNamedChunks :: Bool -- ^ Do we have an explicit export list? + -> HsGroup (GhcPass pass) + -> Map String (HsDoc (GhcPass pass)) +getNamedChunks True decls = + M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case + DocCommentNamed name doc -> Just (name, unLoc doc) + _ -> Nothing +getNamedChunks False _ = M.empty -- | Create decl and arg doc-maps by looping through the declarations. -- For each declaration, find its names, its subordinates, and its doc strings. -mkMaps :: [Name] - -> [(LHsDecl GhcRn, [HsDocString])] - -> (Map Name (HsDocString), Map Name (IntMap HsDocString)) -mkMaps instances decls = - ( f' (map (nubByName fst) decls') - , f (filterMapping (not . IM.null) args) +mkMaps :: OccEnv Name + -> [Name] + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] + -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn))) +mkMaps env instances decls = + ( listsToMapWith (++) (map (nubByName fst) decls') + , listsToMapWith (<>) (filterMapping (not . IM.null) args) ) where (decls', args) = unzip (map mappings decls) - f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b - f = M.fromListWith (<>) . concat - - f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString - f' = M.fromListWith appendDocs . concat + listsToMapWith f = listToUniqMap_C f . concat filterMapping :: (b -> Bool) -> [[(a, b)]] -> [[(a, b)]] filterMapping p = map (filter (p . snd)) - mappings :: (LHsDecl GhcRn, [HsDocString]) - -> ( [(Name, HsDocString)] - , [(Name, IntMap HsDocString)] + mappings :: (LHsDecl GhcRn, [HsDoc GhcRn]) + -> ( [(Name, [HsDoc GhcRn])] + , [(Name, IntMap (HsDoc GhcRn))] ) - mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) = + mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) = (dm, am) where - doc = concatDocs docStrs args = declTypeDocs decl - subs :: [(Name, [HsDocString], IntMap HsDocString)] - subs = subordinates instanceMap decl + subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] + subs = subordinates env instanceMap decl - (subDocs, subArgs) = - unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs) + (subNs, subDocs, subArgs) = + unzip3 subs ns = names l decl - subNs = [ n | (n, _, _) <- subs ] - dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] + dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d] am = [(n, args) | n <- ns] ++ zip subNs subArgs mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], []) @@ -124,7 +270,7 @@ mkMaps instances decls = names :: RealSrcSpan -> HsDecl GhcRn -> [Name] names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1]. - names _ decl = getMainDeclBinder decl + names _ decl = getMainDeclBinder env decl {- Note [1]: @@ -135,27 +281,37 @@ looking at GHC sources). We can assume that commented instances are user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -} -getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p)) - => HsDecl (GhcPass p) -> [IdP (GhcPass p)] -getMainDeclBinder (TyClD _ d) = [tcdName d] -getMainDeclBinder (ValD _ d) = + +getMainDeclBinder + :: OccEnv Name -- ^ Default method environment for this module. See Note [default method Name] in GHC.Iface.Recomp + -> HsDecl GhcRn -> [Name] +getMainDeclBinder _ (TyClD _ d) = [tcdName d] +getMainDeclBinder _ (ValD _ d) = case collectHsBindBinders CollNoDictBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinder (SigD _ d) = sigNameNoLoc d -getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] -getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] -getMainDeclBinder _ = [] - - -sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass] -sigNameNoLoc (TypeSig _ ns _) = map (unXRec @pass) ns -sigNameNoLoc (ClassOpSig _ _ ns _) = map (unXRec @pass) ns -sigNameNoLoc (PatSynSig _ ns _) = map (unXRec @pass) ns -sigNameNoLoc (SpecSig _ n _ _) = [unXRec @pass n] -sigNameNoLoc (InlineSig _ n _) = [unXRec @pass n] -sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns -sigNameNoLoc _ = [] +getMainDeclBinder env (SigD _ d) = sigNameNoLoc env d +getMainDeclBinder _ (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder _ (ForD _ (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ _ = [] + + +-- | The "OccEnv Name" is the default method environment for this module +-- Ultimately, the a special "defaultMethodOcc" name is used for +-- the signatures on bindings for default methods. Unfortunately, this +-- name isn't generated until typechecking, so it is not in the renamed AST. +-- We have to look it up from the 'OccEnv' parameter constructed from the typechecked +-- AST. +-- See also Note [default method Name] in GHC.Iface.Recomp +sigNameNoLoc :: forall a . (UnXRec a, HasOccName (IdP a)) => OccEnv (IdP a) -> Sig a -> [IdP a] +sigNameNoLoc _ (TypeSig _ ns _) = map (unXRec @a) ns +sigNameNoLoc _ (ClassOpSig _ False ns _) = map (unXRec @a) ns +sigNameNoLoc env (ClassOpSig _ True ns _) = mapMaybe (lookupOccEnv env . mkDefaultMethodOcc . occName) $ map (unXRec @a) ns +sigNameNoLoc _ (PatSynSig _ ns _) = map (unXRec @a) ns +sigNameNoLoc _ (SpecSig _ n _ _) = [unXRec @a n] +sigNameNoLoc _ (InlineSig _ n _) = [unXRec @a n] +sigNameNoLoc _ (FixSig _ (FixitySig _ ns _)) = map (unXRec @a) ns +sigNameNoLoc _ _ = [] -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the @@ -180,15 +336,21 @@ getInstLoc = \case -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class. -subordinates :: Map RealSrcSpan Name +subordinates :: OccEnv Name -- ^ The default method environment + -> Map RealSrcSpan Name -> HsDecl GhcRn - -> [(Name, [HsDocString], IntMap HsDocString)] -subordinates instMap decl = case decl of - InstD _ (ClsInstD _ d) -> do - DataFamInstDecl { dfid_eqn = - FamEqn { feqn_tycon = L l _ - , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d - [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn + -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] +subordinates env instMap decl = case decl of + InstD _ (ClsInstD _ d) -> let + data_fams = do + DataFamInstDecl { dfid_eqn = + FamEqn { feqn_tycon = L l _ + , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d + [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn + ty_fams = do + TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d + [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] + in data_fams ++ ty_fams InstD _ (DataFamInstD _ (DataFamInstDecl d)) -> dataSubs (feqn_rhs d) @@ -198,11 +360,11 @@ subordinates instMap decl = case decl of where classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd - , name <- getMainDeclBinder d, not (isValD d) + , name <- getMainDeclBinder env d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn - -> [(Name, [HsDocString], IntMap HsDocString)] - dataSubs dd = constrs ++ fields ++ derivs + -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] + dataSubs dd = constrs ++ fields ++ derivs where cons = map unLoc $ (dd_cons dd) constrs = [ ( unLoc cname @@ -220,13 +382,13 @@ subordinates instMap decl = case decl of dd_derivs dd , Just instName <- [lookupSrcSpan l instMap] ] - extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)] + extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDoc GhcRn)] extract_deriv_clause_tys (L _ dct) = case dct of DctSingle _ ty -> maybeToList $ extract_deriv_ty ty DctMulti _ tys -> mapMaybe extract_deriv_ty tys - extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString) + extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDoc GhcRn) extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) = case ty of -- deriving (C a {- ^ Doc comment -}) @@ -234,25 +396,25 @@ subordinates instMap decl = case decl of _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. -conArgDocs :: ConDecl GhcRn -> IntMap HsDocString +conArgDocs :: ConDecl GhcRn -> IntMap (HsDoc GhcRn) conArgDocs (ConDeclH98{con_args = args}) = h98ConArgDocs args conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) = gadtConArgDocs args (unLoc res_ty) -h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString +h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) h98ConArgDocs con_args = case con_args of PrefixCon _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1) , unLoc (hsScaledThing arg2) ] RecCon _ -> IM.empty -gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString +gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn) gadtConArgDocs con_args res_ty = case con_args of PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty] RecConGADT _ _ -> con_arg_docs 1 [res_ty] -con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString +con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn) con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..] where f n (HsDocTy _ _ lds) = Just (n, unLoc lds) @@ -265,7 +427,7 @@ isValD _ = False -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. -classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -275,7 +437,7 @@ classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ -- | Extract function argument docs from inside top-level decls. -declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString) +declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn) declTypeDocs = \case SigD _ (TypeSig _ _ ty) -> sigTypeDocs (unLoc (dropWildCards ty)) SigD _ (ClassOpSig _ _ _ ty) -> sigTypeDocs (unLoc ty) @@ -296,7 +458,7 @@ nubByName f ns = go emptyNameSet ns y = f x -- | Extract function argument docs from inside types. -typeDocs :: HsType GhcRn -> IntMap HsDocString +typeDocs :: HsType GhcRn -> IntMap (HsDoc GhcRn) typeDocs = go 0 where go n = \case @@ -308,12 +470,12 @@ typeDocs = go 0 _ -> IM.empty -- | Extract function argument docs from inside types. -sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString +sigTypeDocs :: HsSigType GhcRn -> IntMap (HsDoc GhcRn) sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body) -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. @@ -340,14 +502,14 @@ ungroup group_ = -- | Collect docs and attach them to the right declarations. -- -- A declaration may have multiple doc strings attached to it. -collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])] +collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])] -- ^ This is an example. collectDocs = go [] Nothing where go docs mprev decls = case (decls, mprev) of - ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (s:docs) Nothing ds - ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds - ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (s:docs) mprev ds + ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (unLoc s:docs) Nothing ds + ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds + ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (unLoc s:docs) mprev ds (d : ds, Nothing) -> go docs (Just d) ds (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds ([] , Nothing) -> [] @@ -401,14 +563,15 @@ extractTHDocs :: THDocs extractTHDocs docs = -- Split up docs into separate maps for each 'DocLoc' type ExtractedTHDocs - docHeader - (DeclDocMap (searchDocs decl)) - (ArgDocMap (searchDocs args)) - (DeclDocMap (searchDocs insts)) + { ethd_mod_header = docHeader + , ethd_decl_docs = searchDocs decl + , ethd_arg_docs = searchDocs args + , ethd_inst_docs = searchDocs insts + } where - docHeader :: Maybe HsDocString + docHeader :: Maybe (HsDoc GhcRn) docHeader - | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s) + | ((_, s):_) <- filter isModDoc (M.toList docs) = Just s | otherwise = Nothing isModDoc (ModuleDoc, _) = True @@ -417,38 +580,40 @@ extractTHDocs docs = -- Folds over the docs, applying 'f' as the accumulating function. -- We use different accumulating functions to sift out the specific types of -- documentation - searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a - searchDocs f = foldl' f mempty $ M.toList docs + searchDocs :: (UniqMap Name a -> (DocLoc, HsDoc GhcRn) -> UniqMap Name a) -> UniqMap Name a + searchDocs f = foldl' f emptyUniqMap $ M.toList docs -- Pick out the declaration docs - decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc + decl acc ((DeclDoc name), s) = addToUniqMap acc name s decl acc _ = acc -- Pick out the instance docs - insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc + insts acc ((InstDoc name), s) = addToUniqMap acc name s insts acc _ = acc -- Pick out the argument docs - args :: Map Name (IntMap HsDocString) - -> (DocLoc, String) - -> Map Name (IntMap HsDocString) + args :: UniqMap Name (IntMap (HsDoc GhcRn)) + -> (DocLoc, HsDoc GhcRn) + -> UniqMap Name (IntMap (HsDoc GhcRn)) args acc ((ArgDoc name i), s) = -- Insert the doc for the arg into the argument map for the function. This -- means we have to search to see if an map already exists for the -- function, and insert the new argument if it exists, or create a new map - let ds = mkHsDocString s - in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc + addToUniqMap_C (\_ m -> IM.insert i s m) acc name (IM.singleton i s) args acc _ = acc -- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two -- maps with values for the same key merge the inner map as well. -- Left biased so @unionArgMaps a b@ prefers @a@ over @b@. -unionArgMaps :: Map Name (IntMap b) - -> Map Name (IntMap b) - -> Map Name (IntMap b) -unionArgMaps a b = M.foldlWithKey go b a + +unionArgMaps :: forall b . UniqMap Name (IntMap b) + -> UniqMap Name (IntMap b) + -> UniqMap Name (IntMap b) +unionArgMaps a b = nonDetFoldUniqMap go b a where - go acc n newArgMap - | Just oldArgMap <- M.lookup n acc = - M.insert n (newArgMap `IM.union` oldArgMap) acc - | otherwise = M.insert n newArgMap acc + go :: (Name, IntMap b) + -> UniqMap Name (IntMap b) -> UniqMap Name (IntMap b) + go (n, newArgMap) acc + | Just oldArgMap <- lookupUniqMap acc n = + addToUniqMap acc n (newArgMap `IM.union` oldArgMap) + | otherwise = addToUniqMap acc n newArgMap diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 60885ae7ee..73ad2a09b7 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -205,7 +205,7 @@ call and just recurse directly in to the subexpressions. -- These synonyms match those defined in compiler/GHC.hs type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] , Maybe [(LIE GhcRn, Avails)] - , Maybe LHsDocString ) + , Maybe (LHsDoc GhcRn) ) type TypecheckedSource = LHsBinds GhcTc @@ -316,12 +316,13 @@ getCompressedAsts ts rs top_ev_binds insts tcs = enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> HieASTs Type -enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = +enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs = runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts rasts <- processGrp hsGrp imps <- toHie $ filter (not . ideclImplicit . unLoc) imports exps <- toHie $ fmap (map $ IEC Export . fst) exports + docs <- toHie docs -- Add Instance bindings forM_ insts $ \i -> addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing) @@ -341,6 +342,7 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = , rasts , imps , exps + , docs ] modulify (HiePath file) xs' = do @@ -387,6 +389,7 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = , toHie $ hs_warnds grp , toHie $ hs_annds grp , toHie $ hs_ruleds grp + , toHie $ hs_docs grp ] getRealSpanA :: SrcSpanAnn' ann -> Maybe Span @@ -1596,7 +1599,8 @@ instance ToHie a => ToHie (HsScaled GhcRn a) where instance ToHie (LocatedA (ConDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs - , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } -> + , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ + , con_doc = doc} -> [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names , case outer_bndrs of HsOuterImplicit{hso_ximplicit = imp_vars} -> @@ -1607,6 +1611,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where , toHie ctx , toHie args , toHie typ + , toHie doc ] where rhsScope = combineScopes argsScope tyScope @@ -1617,11 +1622,13 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where tyScope = mkLScopeA typ resScope = ResolvedScopes [ctxScope, rhsScope] ConDeclH98 { con_name = name, con_ex_tvs = qvars - , con_mb_cxt = ctx, con_args = dets } -> + , con_mb_cxt = ctx, con_args = dets + , con_doc = doc} -> [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars , toHie ctx , toHie dets + , toHie doc ] where rhsScope = combineScopes ctxScope argsScope @@ -1780,8 +1787,9 @@ instance ToHie (LocatedA (HsType GhcRn)) where HsSpliceTy _ a -> [ toHie $ L span a ] - HsDocTy _ a _ -> + HsDocTy _ a doc -> [ toHie a + , toHie doc ] HsBangTy _ _ ty -> [ toHie ty @@ -1832,9 +1840,10 @@ instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where instance ToHie (LocatedA (ConDeclField GhcRn)) where toHie (L span field) = concatM $ makeNode field (locA span) : case field of - ConDeclField _ fields typ _ -> + ConDeclField _ fields typ doc -> [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields , toHie typ + , toHie doc ] instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where @@ -2088,8 +2097,8 @@ instance ToHie (IEContext (LocatedA (IE GhcRn))) where IEModuleContents _ n -> [ toHie $ IEC c n ] - IEGroup _ _ _ -> [] - IEDoc _ _ -> [] + IEGroup _ _ d -> [toHie d] + IEDoc _ d -> [toHie d] IEDocNamed _ _ -> [] instance ToHie (IEContext (LIEWrappedName Name)) where @@ -2109,3 +2118,13 @@ instance ToHie (IEContext (Located FieldLabel)) where [ makeNode lbl span , toHie $ C (IEThing c) $ L span (flSelector lbl) ] + +instance ToHie (LocatedA (DocDecl GhcRn)) where + toHie (L span d) = concatM $ makeNodeA d span : case d of + DocCommentNext d -> [ toHie d ] + DocCommentPrev d -> [ toHie d ] + DocCommentNamed _ d -> [ toHie d ] + DocGroup _ d -> [ toHie d ] + +instance ToHie (LHsDoc GhcRn) where + toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids] diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 0055cea807..18554fdc50 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -21,7 +21,7 @@ module GHC.Iface.Load ( -- RnM/TcM functions loadModuleInterface, loadModuleInterfaces, loadSrcInterface, loadSrcInterface_maybe, - loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule, + loadInterfaceForName, loadInterfaceForModule, -- IfM functions loadInterface, @@ -349,15 +349,6 @@ loadInterfaceForName doc name ; assertPpr (isExternalName name) (ppr name) $ initIfaceTcRn $ loadSysInterface doc (nameModule name) } --- | Only loads the interface for external non-local names. -loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface) -loadInterfaceForNameMaybe doc name - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod name || not (isExternalName name) - then return Nothing - else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name)) - } - -- | Loads the interface for a given Module. loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface loadInterfaceForModule doc m @@ -1025,7 +1016,7 @@ ghcPrimIface mi_decls = [], mi_fixities = fixities, mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities }, - mi_decl_docs = ghcPrimDeclDocs -- See Note [GHC.Prim Docs] + mi_docs = Just ghcPrimDeclDocs -- See Note [GHC.Prim Docs] } where empty_iface = emptyFullModIface gHC_PRIM @@ -1142,9 +1133,7 @@ pprModIface unit_state iface@ModIface{ mi_final_exts = exts } , pprTrustInfo (mi_trust iface) , pprTrustPkg (mi_trust_pkg iface) , vcat (map ppr (mi_complete_matches iface)) - , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface)) - , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface)) - , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface)) + , text "docs:" $$ nest 2 (ppr (mi_docs iface)) , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface)) ] where @@ -1209,13 +1198,13 @@ pprTrustInfo trust = text "trusted:" <+> ppr trust pprTrustPkg :: Bool -> SDoc pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg -instance Outputable Warnings where +instance Outputable (Warnings pass) where ppr = pprWarns -pprWarns :: Warnings -> SDoc +pprWarns :: Warnings pass -> SDoc pprWarns NoWarnings = Outputable.empty pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt -pprWarns (WarnSome prs) = text "Warnings" +pprWarns (WarnSome prs) = text "Warnings:" <+> vcat (map pprWarning prs) where pprWarning (name, txt) = ppr name <+> ppr txt diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 19739ff3e3..7cf782a18d 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -125,12 +125,10 @@ mkPartialIface hsc_env mod_details mod_summary , mg_hpc_info = hpc_info , mg_safe_haskell = safe_mode , mg_trust_pkg = self_trust - , mg_doc_hdr = doc_hdr - , mg_decl_docs = decl_docs - , mg_arg_docs = arg_docs + , mg_docs = docs } = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust - safe_mode usages doc_hdr decl_docs arg_docs mod_summary mod_details + safe_mode usages docs mod_summary mod_details -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information. @@ -222,34 +220,32 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files merged needed_links needed_pkgs - (doc_hdr', doc_map, arg_map) <- extractDocs tc_result + docs <- extractDocs (ms_hspp_opts mod_summary) tc_result let partial_iface = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info (imp_trust_own_pkg imports) safe_mode usages - doc_hdr' doc_map arg_map mod_summary + docs mod_summary mod_details mkFullIface hsc_env partial_iface Nothing mkIface_ :: HscEnv -> Module -> HscSource -> Bool -> Dependencies -> GlobalRdrEnv - -> NameEnv FixItem -> Warnings -> HpcInfo + -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo -> Bool -> SafeHaskellMode -> [Usage] - -> Maybe HsDocString - -> DeclDocMap - -> ArgDocMap + -> Maybe Docs -> ModSummary -> ModDetails -> PartialModIface mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env src_warns hpc_info pkg_trust_req safe_mode usages - doc_hdr decl_docs arg_docs mod_summary + docs mod_summary ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -322,9 +318,7 @@ mkIface_ hsc_env mi_trust = trust_info, mi_trust_pkg = pkg_trust_req, mi_complete_matches = icomplete_matches, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, + mi_docs = docs, mi_final_exts = (), mi_ext_fields = emptyExtensibleFields, mi_src_hash = ms_hs_hash mod_summary diff --git a/compiler/GHC/Parser.hs-boot b/compiler/GHC/Parser.hs-boot new file mode 100644 index 0000000000..6d5cb4c68f --- /dev/null +++ b/compiler/GHC/Parser.hs-boot @@ -0,0 +1,7 @@ +module GHC.Parser where + +import GHC.Types.Name.Reader (RdrName) +import GHC.Parser.Lexer (P) +import GHC.Parser.Annotation (LocatedN) + +parseIdentifier :: P (LocatedN RdrName) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index ce1c48b99d..418d67dc67 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -83,6 +83,7 @@ import GHC.Core.DataCon ( DataCon, dataConName ) import GHC.Parser.PostProcess import GHC.Parser.PostProcess.Haddock import GHC.Parser.Lexer +import GHC.Parser.HaddockLex import GHC.Parser.Annotation import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr () @@ -902,12 +903,12 @@ missing_module_keyword :: { () } implicit_top :: { () } : {- empty -} {% pushModuleContext } -maybemodwarning :: { Maybe (LocatedP WarningTxt) } +maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (snd $ unLoc $2)) + {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) } | '{-# WARNING' strings '#-}' - {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (snd $ unLoc $2)) + {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2)) (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))} | {- empty -} { Nothing } @@ -1940,7 +1941,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : namelist strings {% fmap unitOL $ acsA (\cs -> sLL $1 $> (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1) - (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) } + (WarningTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) } deprecations :: { OrdList (LWarnDecl GhcPs) } : deprecations ';' deprecation @@ -1963,7 +1964,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namelist strings {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1) - (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) } + (DeprecatedTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) } strings :: { Located ([AddEpAnn],[Located StringLiteral]) } : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } @@ -3962,6 +3963,9 @@ getSCC lt = do let s = getSTRING lt then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC else return s +stringLiteralToHsDocWst :: Located StringLiteral -> Located (WithHsDocIdentifiers StringLiteral GhcPs) +stringLiteralToHsDocWst = lexStringLiteral parseIdentifier + -- Utilities for combining source spans comb2 :: Located a -> Located b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 1f48615aec..dd0cdd3123 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -93,6 +93,7 @@ import Data.Semigroup import GHC.Data.FastString import GHC.Types.Name import GHC.Types.SrcLoc +import GHC.Hs.DocString import GHC.Utils.Binary import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic @@ -358,14 +359,11 @@ data EpaComment = -- and the start of this location is used for the spacing when -- exact printing the comment. } - deriving (Eq, Ord, Data, Show) + deriving (Eq, Data, Show) data EpaCommentTok = -- Documentation annotations - EpaDocCommentNext String -- ^ something beginning '-- |' - | EpaDocCommentPrev String -- ^ something beginning '-- ^' - | EpaDocCommentNamed String -- ^ something beginning '-- $' - | EpaDocSection Int String -- ^ a section heading + EpaDocComment HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc) | EpaLineComment String -- ^ comment starting by "--" | EpaBlockComment String -- ^ comment in {- -} @@ -376,7 +374,7 @@ data EpaCommentTok = -- should be removed in favour of capturing it in the location for -- 'Located HsModule' in the parser. - deriving (Eq, Ord, Data, Show) + deriving (Eq, Data, Show) -- Note: these are based on the Token versions, but the Token type is -- defined in GHC.Parser.Lexer and bringing it in here would create a loop @@ -407,12 +405,12 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) -- sort the relative order. data EpaLocation = EpaSpan !RealSrcSpan | EpaDelta !DeltaPos ![LEpaComment] - deriving (Data,Eq,Ord) + deriving (Data,Eq) -- | Tokens embedded in the AST have an EpaLocation, unless they come from -- generated code (e.g. by TH). data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation - deriving (Data,Eq,Ord) + deriving (Data,Eq) -- | Spacing between output items when exact printing. It captures -- the spacing from the current print position on the page to the @@ -460,9 +458,6 @@ instance Outputable EpaLocation where instance Outputable AddEpAnn where ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss -instance Ord AddEpAnn where - compare (AddEpAnn kw1 loc1) (AddEpAnn kw2 loc2) = compare (loc1, kw1) (loc2,kw2) - -- --------------------------------------------------------------------- -- | The exact print annotations (EPAs) are kept in the HsSyn AST for @@ -640,7 +635,7 @@ data TrailingAnn = AddSemiAnn EpaLocation -- ^ Trailing ';' | AddCommaAnn EpaLocation -- ^ Trailing ',' | AddVbarAnn EpaLocation -- ^ Trailing '|' - deriving (Data, Eq, Ord) + deriving (Data, Eq) instance Outputable TrailingAnn where ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss diff --git a/compiler/GHC/Parser/HaddockLex.x b/compiler/GHC/Parser/HaddockLex.x new file mode 100644 index 0000000000..e215769f9e --- /dev/null +++ b/compiler/GHC/Parser/HaddockLex.x @@ -0,0 +1,201 @@ +{ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Hs.Doc +import GHC.Parser.Lexer +import GHC.Parser.Annotation +import GHC.Types.SrcLoc +import GHC.Types.SourceText +import GHC.Data.StringBuffer +import qualified GHC.Data.Strict as Strict +import GHC.Types.Name.Reader +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Encoding +import GHC.Hs.Extension + +import qualified GHC.Data.EnumSet as EnumSet + +import Data.Maybe +import Data.Word + +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS + +import qualified GHC.LanguageExtensions as LangExt +} + +-- ----------------------------------------------------------------------------- +-- Alex "Character set macros" +-- Copied from GHC/Parser/Lexer.x + +-- NB: The logic behind these definitions is also reflected in "GHC.Utils.Lexeme" +-- Any changes here should likely be reflected there. +$unispace = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$nl = [\n\r\f] +$whitechar = [$nl\v\ $unispace] +$white_no_nl = $whitechar # \n -- TODO #8424 +$tab = \t + +$ascdigit = 0-9 +$unidigit = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$decdigit = $ascdigit -- exactly $ascdigit, no more no less. +$digit = [$ascdigit $unidigit] + +$special = [\(\)\,\;\[\]\`\{\}] +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] +$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$symbol = [$ascsymbol $unisymbol] # [$special \_\"\'] + +$unilarge = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$asclarge = [A-Z] +$large = [$asclarge $unilarge] + +$unismall = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$ascsmall = [a-z] +$small = [$ascsmall $unismall \_] + +$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$idchar = [$small $large $digit $uniidchar \'] + +$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. +$graphic = [$small $large $symbol $digit $idchar $special $unigraphic \"\'] + +$alpha = [$small $large] + +-- The character sets marked "TODO" are mostly overly inclusive +-- and should be defined more precisely once alex has better +-- support for unicode character sets (see +-- https://github.com/simonmar/alex/issues/126). + +@id = $alpha $idchar* \#* | $symbol+ +@modname = $large $idchar* +@qualid = (@modname \.)* @id + +:- + \' @qualid \' | \` @qualid \` { getIdentifier 1 } + \'\` @qualid \`\' | \'\( @qualid \)\' | \`\( @qualid \)\` { getIdentifier 2 } + [. \n] ; + +{ +data AlexInput = AlexInput + { alexInput_position :: !RealSrcLoc + , alexInput_string :: !ByteString + } + +-- NB: As long as we don't use a left-context we don't need to track the +-- previous input character. +alexInputPrevChar :: AlexInput -> Word8 +alexInputPrevChar = error "Left-context not supported" + +alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) +alexGetByte (AlexInput p s) = case utf8UnconsByteString s of + Nothing -> Nothing + Just (c,bs) -> Just (adjustChar c, AlexInput (advanceSrcLoc p c) bs) + +alexScanTokens :: RealSrcLoc -> ByteString -> [(RealSrcSpan, ByteString)] +alexScanTokens start str0 = go (AlexInput start str0) + where go inp@(AlexInput pos str) = + case alexScan inp 0 of + AlexSkip inp' _ln -> go inp' + AlexToken inp'@(AlexInput _ str') _ act -> act pos (BS.length str - BS.length str') str : go inp' + AlexEOF -> [] + AlexError (AlexInput p _) -> error $ "lexical error at " ++ show p + +-------------------------------------------------------------------------------- + +-- | Extract identifier from Alex state. +getIdentifier :: Int -- ^ adornment length + -> RealSrcLoc + -> Int + -- ^ Token length + -> ByteString + -- ^ The remaining input beginning with the found token + -> (RealSrcSpan, ByteString) +getIdentifier !i !loc0 !len0 !s0 = + (mkRealSrcSpan loc1 loc2, ident) + where + (adornment, s1) = BS.splitAt i s0 + ident = BS.take (len0 - 2*i) s1 + loc1 = advanceSrcLocBS loc0 adornment + loc2 = advanceSrcLocBS loc1 ident + +advanceSrcLocBS :: RealSrcLoc -> ByteString -> RealSrcLoc +advanceSrcLocBS !loc bs = case utf8UnconsByteString bs of + Nothing -> loc + Just (c, bs') -> advanceSrcLocBS (advanceSrcLoc loc c) bs' + +-- | Lex 'StringLiteral' for warning messages +lexStringLiteral :: P (LocatedN RdrName) -- ^ A precise identifier parser + -> Located StringLiteral + -> Located (WithHsDocIdentifiers StringLiteral GhcPs) +lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) + = L l (WithHsDocIdentifiers sl idents) + where + bs = bytesFS fs + + idents = mapMaybe (uncurry (validateIdentWith identParser)) plausibleIdents + + plausibleIdents :: [(SrcSpan,ByteString)] + plausibleIdents = case l of + RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] + UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] + + fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 + +-- | Lex identifiers from a docstring. +lexHsDoc :: P (LocatedN RdrName) -- ^ A precise identifier parser + -> HsDocString + -> HsDoc GhcPs +lexHsDoc identParser doc = + WithHsDocIdentifiers doc idents + where + docStrings = docStringChunks doc + idents = concat [mapMaybe maybeDocIdentifier (plausibleIdents doc) | doc <- docStrings] + + maybeDocIdentifier :: (SrcSpan, ByteString) -> Maybe (Located RdrName) + maybeDocIdentifier = uncurry (validateIdentWith identParser) + + plausibleIdents :: LHsDocStringChunk -> [(SrcSpan,ByteString)] + plausibleIdents (L (RealSrcSpan span _) (HsDocStringChunk s)) + = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] + plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) + = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason + + fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 + +validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName) +validateIdentWith identParser mloc str0 = + let -- These ParserFlags should be as "inclusive" as possible, allowing + -- identifiers defined with any language extension. + pflags = mkParserOpts + (EnumSet.fromList [LangExt.MagicHash]) + dopts + [] + False False False False + dopts = DiagOpts + { diag_warning_flags = EnumSet.empty + , diag_fatal_warning_flags = EnumSet.empty + , diag_warn_is_error = False + , diag_reverse_errors = False + , diag_max_errors = Nothing + , diag_ppr_ctx = defaultSDocContext + } + buffer = stringBufferFromByteString str0 + realSrcLc = case mloc of + RealSrcSpan loc _ -> realSrcSpanStart loc + UnhelpfulSpan _ -> mkRealSrcLoc (mkFastString "") 0 0 + pstate = initParserState pflags buffer realSrcLc + in case unP identParser pstate of + POk _ name -> Just $ case mloc of + RealSrcSpan _ _ -> reLoc name + UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason + _ -> Nothing +} diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index cb8a5c334e..87f20b5c9c 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -301,13 +300,10 @@ getOptions' opts toks isComment :: Token -> Bool isComment c = case c of - (ITlineComment {}) -> True - (ITblockComment {}) -> True - (ITdocCommentNext {}) -> True - (ITdocCommentPrev {}) -> True - (ITdocCommentNamed {}) -> True - (ITdocSection {}) -> True - _ -> False + (ITlineComment {}) -> True + (ITblockComment {}) -> True + (ITdocComment {}) -> True + _ -> False toArgs :: RealSrcLoc -> String -> Either String -- Error diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 7d7d157d2b..02717c7dae 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -76,6 +76,7 @@ module GHC.Parser.Lexer ( commentToAnnotation, HdkComment(..), warnopt, + adjustChar, addPsMessage ) where @@ -87,6 +88,8 @@ import Control.Monad import Control.Applicative import Data.Char import Data.List (stripPrefix, isInfixOf, partition) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Word import Debug.Trace (trace) @@ -134,34 +137,34 @@ import GHC.Parser.Errors.Ppr () -- NB: The logic behind these definitions is also reflected in "GHC.Utils.Lexeme" -- Any changes here should likely be reflected there. -$unispace = \x05 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unispace = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $nl = [\n\r\f] $whitechar = [$nl\v\ $unispace] $white_no_nl = $whitechar # \n -- TODO #8424 $tab = \t $ascdigit = 0-9 -$unidigit = \x03 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unidigit = \x03 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $decdigit = $ascdigit -- exactly $ascdigit, no more no less. $digit = [$ascdigit $unidigit] $special = [\(\)\,\;\[\]\`\{\}] $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] -$unisymbol = \x04 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unisymbol = \x04 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $symbol = [$ascsymbol $unisymbol] # [$special \_\"\'] -$unilarge = \x01 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unilarge = \x01 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $asclarge = [A-Z] $large = [$asclarge $unilarge] -$unismall = \x02 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unismall = \x02 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $ascsmall = [a-z] $small = [$ascsmall $unismall \_] -$uniidchar = \x07 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$uniidchar = \x07 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $idchar = [$small $large $digit $uniidchar \'] -$unigraphic = \x06 -- Trick Alex into handling Unicode. See [Unicode in Alex]. +$unigraphic = \x06 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $graphic = [$small $large $symbol $digit $idchar $special $unigraphic \"\'] $binit = 0-1 @@ -230,7 +233,7 @@ $tab { warnTab } -- are). We also rule out nested Haddock comments, if the -haddock flag is -- set. -"{-" / { isNormalComment } { nested_comment lexToken } +"{-" / { isNormalComment } { nested_comment } -- Single-line comments are a bit tricky. Haskell 98 says that two or -- more dashes followed by a symbol should be parsed as a varsym, so we @@ -364,12 +367,12 @@ $tab { warnTab } <0> { -- In the "0" mode we ignore these pragmas "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } - { nested_comment lexToken } + { nested_comment } } <0,option_prags> { "{-#" { warnThen PsWarnUnrecognisedPragma - (nested_comment lexToken) } + (nested_comment ) } } -- '0' state: ordinary lexemes @@ -883,13 +886,11 @@ data Token | ITeof -- ^ end of file token -- Documentation annotations. See Note [PsSpan in Comments] - | ITdocCommentNext String PsSpan -- ^ something beginning @-- |@ - | ITdocCommentPrev String PsSpan -- ^ something beginning @-- ^@ - | ITdocCommentNamed String PsSpan -- ^ something beginning @-- $@ - | ITdocSection Int String PsSpan -- ^ a section heading - | ITdocOptions String PsSpan -- ^ doc options (prune, ignore-exports, etc) - | ITlineComment String PsSpan -- ^ comment starting by "--" - | ITblockComment String PsSpan -- ^ comment in {- -} + | ITdocComment HsDocString PsSpan -- ^ The HsDocString contains more details about what + -- this is and how to pretty print it + | ITdocOptions String PsSpan -- ^ doc options (prune, ignore-exports, etc) + | ITlineComment String PsSpan -- ^ comment starting by "--" + | ITblockComment String PsSpan -- ^ comment in {- -} deriving Show @@ -1280,16 +1281,23 @@ alexOrPred p1 p2 userState in1 len in2 = p1 userState in1 len in2 || p2 userState in1 len in2 multiline_doc_comment :: Action -multiline_doc_comment span buf _len = withLexedDocType (worker "") +multiline_doc_comment span buf _len = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker where - worker commentAcc input docType checkNextLine = case alexGetChar' input of - Just ('\n', input') - | checkNextLine -> case checkIfCommentLine input' of - Just input -> worker ('\n':commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span - | otherwise -> docCommentEnd input commentAcc docType buf span - Just (c, input) -> worker (c:commentAcc) input docType checkNextLine - Nothing -> docCommentEnd input commentAcc docType buf span + worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input + where + go start_loc curLine prevLines input@(AI end_loc _) = case alexGetChar' input of + Just ('\n', input') + | checkNextLine -> case checkIfCommentLine input' of + Just input@(AI next_start _) -> go next_start "" (locatedLine : prevLines) input -- Start a new line + Nothing -> endComment + | otherwise -> endComment + Just (c, input) -> go start_loc (c:curLine) prevLines input + Nothing -> endComment + where + lineSpan = mkSrcSpanPs $ mkPsSpan start_loc end_loc + locatedLine = L lineSpan (mkHsDocStringChunk $ reverse curLine) + commentLines = NE.reverse $ locatedLine :| prevLines + endComment = docCommentEnd input (docType (\dec -> MultiLineDocString dec commentLines)) buf span -- Check if the next line of input belongs to this doc comment as well. -- A doc comment continues onto the next line when the following @@ -1331,15 +1339,43 @@ lineCommentToken span buf len = do nested comments require traversing by hand, they can't be parsed using regular expressions. -} -nested_comment :: P (PsLocated Token) -> Action -nested_comment cont span buf len = do +nested_comment :: Action +nested_comment span buf len = {-# SCC "nested_comment" #-} do + l <- getLastLocComment + let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span input <- getInput - go (reverse $ lexemeToString buf len) (1::Int) input + -- Include decorator in comment + let start_decorator = reverse $ lexemeToString buf len + nested_comment_logic endComment start_decorator input span + +nested_doc_comment :: Action +nested_doc_comment span buf _len = {-# SCC "nested_doc_comment" #-} withLexedDocType worker + where + worker input docType _checkNextLine = nested_comment_logic endComment "" input span + where + endComment input lcomment + = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span + + dropTrailingDec [] = [] + dropTrailingDec "-}" = "" + dropTrailingDec (x:xs) = x:dropTrailingDec xs + +{-# INLINE nested_comment_logic #-} +-- | Includes the trailing '-}' decorators +-- drop the last two elements with the callback if you don't want them to be included +nested_comment_logic + :: (AlexInput -> Located String -> P (PsLocated Token)) -- ^ Continuation that gets the rest of the input and the lexed comment + -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment + -> AlexInput + -> PsSpan + -> P (PsLocated Token) +nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input where - go commentAcc 0 input = do - l <- getLastLocComment - let finalizeComment str = (Nothing, ITblockComment str l) - commentEnd cont input commentAcc finalizeComment buf span + go commentAcc 0 input@(AI end_loc _) = do + let comment = reverse commentAcc + cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc + lcomment = L cspan comment + endComment input lcomment go commentAcc n input = case alexGetChar' input of Nothing -> errBrace input (psRealSpan span) Just ('-',input) -> case alexGetChar' input of @@ -1358,31 +1394,6 @@ nested_comment cont span buf len = do Just (_,_) -> go ('\n':commentAcc) n input Just (c,input) -> go (c:commentAcc) n input -nested_doc_comment :: Action -nested_doc_comment span buf _len = withLexedDocType (go "") - where - go commentAcc input docType _ = case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('\125',input) -> - docCommentEnd input commentAcc docType buf span - Just (_,_) -> go ('-':commentAcc) input docType False - Just ('\123', input) -> case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('-',input) -> do - setInput input - let cont = do input <- getInput; go commentAcc input docType False - nested_comment cont span buf _len - Just (_,_) -> go ('\123':commentAcc) input docType False - -- See Note [Nested comment line pragmas] - Just ('\n',input) -> case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input - go (parsedAcc ++ '\n':commentAcc) input docType False - Just (_,_) -> go ('\n':commentAcc) input docType False - Just (c,input) -> go (c:commentAcc) input docType False - -- See Note [Nested comment line pragmas] parseNestedPragma :: AlexInput -> P (String,AlexInput) parseNestedPragma input@(AI _ buf) = do @@ -1429,7 +1440,8 @@ return control to parseNestedPragma by returning the ITcomment_line_prag token. See #314 for more background on the bug this fixes. -} -withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) +{-# INLINE withLexedDocType #-} +withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) -> P (PsLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput @@ -1439,7 +1451,9 @@ withLexedDocType lexDocComment = do -- line of input might also belong to this doc comment. '|' -> lexDocComment input (mkHdkCommentNext l) True '^' -> lexDocComment input (mkHdkCommentPrev l) True - '$' -> lexDocComment input (mkHdkCommentNamed l) True + '$' -> case lexDocName input of + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + Just (name, input) -> lexDocComment input (mkHdkCommentNamed l name) True '*' -> lexDocSection l 1 input _ -> panic "withLexedDocType: Bad doc type" where @@ -1448,18 +1462,28 @@ withLexedDocType lexDocComment = do Just (_, _) -> lexDocComment input (mkHdkCommentSection l n) False Nothing -> do setInput input; lexToken -- eof reached, lex it normally -mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> String -> (HdkComment, Token) -mkHdkCommentNext loc str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str loc) -mkHdkCommentPrev loc str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str loc) + lexDocName :: AlexInput -> Maybe (String, AlexInput) + lexDocName = go "" + where + go acc input = case alexGetChar' input of + Just (c, input') + | isSpace c -> Just (reverse acc, input) + | otherwise -> go (c:acc) input' + Nothing -> Nothing + +mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentNext loc mkDS = (HdkCommentNext ds,ITdocComment ds loc) + where ds = mkDS HsDocStringNext +mkHdkCommentPrev loc mkDS = (HdkCommentPrev ds,ITdocComment ds loc) + where ds = mkDS HsDocStringPrevious -mkHdkCommentNamed :: PsSpan -> String -> (HdkComment, Token) -mkHdkCommentNamed loc str = - let (name, rest) = break isSpace str - in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str loc) +mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc) + where ds = mkDS (HsDocStringNamed name) -mkHdkCommentSection :: PsSpan -> Int -> String -> (HdkComment, Token) -mkHdkCommentSection loc n str = - (HdkCommentSection n (mkHsDocString str), ITdocSection n str loc) +mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc) + where ds = mkDS (HsDocStringGroup n) -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. @@ -1503,34 +1527,30 @@ endPrag span _buf _len = do -- it writes the wrong token length to the parser state. This function is -- called afterwards, so it can just update the state. +{-# INLINE commentEnd #-} commentEnd :: P (PsLocated Token) -> AlexInput - -> String - -> (String -> (Maybe HdkComment, Token)) + -> (Maybe HdkComment, Token) -> StringBuffer -> PsSpan -> P (PsLocated Token) -commentEnd cont input commentAcc finalizeComment buf span = do +commentEnd cont input (m_hdk_comment, hdk_token) buf span = do setInput input let (AI loc nextBuf) = input - comment = reverse commentAcc span' = mkPsSpan (psSpanStart span) loc last_len = byteDiff buf nextBuf span `seq` setLastToken span' last_len - let (m_hdk_comment, hdk_token) = finalizeComment comment whenIsJust m_hdk_comment $ \hdk_comment -> P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) () b <- getBit RawTokenStreamBit if b then return (L span' hdk_token) else cont -docCommentEnd :: AlexInput -> String -> (String -> (HdkComment, Token)) -> StringBuffer -> +{-# INLINE docCommentEnd #-} +docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer -> PsSpan -> P (PsLocated Token) -docCommentEnd input commentAcc docType buf span = do - let finalizeComment str = - let (hdk_comment, token) = docType str - in (Just hdk_comment, token) - commentEnd lexToken input commentAcc finalizeComment buf span +docCommentEnd input (hdk_comment, tok) buf span + = commentEnd lexToken input (Just hdk_comment, tok) buf span errBrace :: AlexInput -> RealSrcSpan -> P a errBrace (AI end _) span = @@ -2331,8 +2351,10 @@ data ParserOpts = ParserOpts pWarningFlags :: ParserOpts -> EnumSet WarningFlag pWarningFlags opts = diag_warning_flags (pDiagOpts opts) --- | Haddock comment as produced by the lexer. These are accumulated in --- 'PState' and then processed in "GHC.Parser.PostProcess.Haddock". +-- | Haddock comment as produced by the lexer. These are accumulated in 'PState' +-- and then processed in "GHC.Parser.PostProcess.Haddock". The location of the +-- 'HsDocString's spans over the contents of the docstring - i.e. it does not +-- include the decorator ("-- |", "{-|" etc.) data HdkComment = HdkCommentNext HsDocString | HdkCommentPrev HsDocString @@ -2596,6 +2618,7 @@ alexGetByte (AI loc s) loc' = advancePsLoc loc c byte = adjustChar c +{-# INLINE alexGetChar' #-} -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) @@ -3386,8 +3409,7 @@ reportLexError loc1 loc2 buf f lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token] lexTokenStream opts buf loc = unP go initState{ options = opts' } where - new_exts = xunset HaddockBit -- disable Haddock - $ xunset UsePosPragsBit -- parse LINE/COLUMN pragmas as tokens + new_exts = xunset UsePosPragsBit -- parse LINE/COLUMN pragmas as tokens $ xset RawTokenStreamBit -- include comments $ pExtsBitmap opts opts' = opts { pExtsBitmap = new_exts } @@ -3407,7 +3429,7 @@ fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), ("include", lex_string_prag ITinclude_prag)]) ignoredPrags = Map.fromList (map ignored pragmas) - where ignored opt = (opt, nested_comment lexToken) + where ignored opt = (opt, nested_comment) impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] options_pragmas = map ("options_" ++) impls -- CFILES is a hugs-only thing. @@ -3553,13 +3575,10 @@ allocateFinalComments ss comment_q mheader_comments = Strict.Just _ -> (mheader_comments, [], comment_q' ++ newAnns) commentToAnnotation :: RealLocated Token -> LEpaComment -commentToAnnotation (L l (ITdocCommentNext s ll)) = mkLEpaComment l ll (EpaDocCommentNext s) -commentToAnnotation (L l (ITdocCommentPrev s ll)) = mkLEpaComment l ll (EpaDocCommentPrev s) -commentToAnnotation (L l (ITdocCommentNamed s ll)) = mkLEpaComment l ll (EpaDocCommentNamed s) -commentToAnnotation (L l (ITdocSection n s ll)) = mkLEpaComment l ll (EpaDocSection n s) -commentToAnnotation (L l (ITdocOptions s ll)) = mkLEpaComment l ll (EpaDocOptions s) -commentToAnnotation (L l (ITlineComment s ll)) = mkLEpaComment l ll (EpaLineComment s) -commentToAnnotation (L l (ITblockComment s ll)) = mkLEpaComment l ll (EpaBlockComment s) +commentToAnnotation (L l (ITdocComment s ll)) = mkLEpaComment l ll (EpaDocComment s) +commentToAnnotation (L l (ITdocOptions s ll)) = mkLEpaComment l ll (EpaDocOptions s) +commentToAnnotation (L l (ITlineComment s ll)) = mkLEpaComment l ll (EpaLineComment s) +commentToAnnotation (L l (ITblockComment s ll)) = mkLEpaComment l ll (EpaBlockComment s) commentToAnnotation _ = panic "commentToAnnotation" -- see Note [PsSpan in Comments] @@ -3569,12 +3588,9 @@ mkLEpaComment l ll tok = L (realSpanAsAnchor l) (EpaComment tok (psRealSpan ll)) -- --------------------------------------------------------------------- isComment :: Token -> Bool -isComment (ITlineComment _ _) = True -isComment (ITblockComment _ _) = True -isComment (ITdocCommentNext _ _) = True -isComment (ITdocCommentPrev _ _) = True -isComment (ITdocCommentNamed _ _) = True -isComment (ITdocSection _ _ _) = True -isComment (ITdocOptions _ _) = True -isComment _ = False +isComment (ITlineComment _ _) = True +isComment (ITblockComment _ _) = True +isComment (ITdocComment _ _) = True +isComment (ITdocOptions _ _) = True +isComment _ = False } diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 08bebc4683..271d9db30f 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -67,7 +67,9 @@ import Control.Monad.Trans.Writer import Data.Functor.Identity import qualified Data.Monoid +import {-# SOURCE #-} GHC.Parser (parseIdentifier) import GHC.Parser.Lexer +import GHC.Parser.HaddockLex import GHC.Parser.Errors.Types import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) import qualified GHC.Data.Strict as Strict @@ -252,7 +254,8 @@ instance HasHaddock (Located HsModule) where docs <- inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $ takeHdkComments mkDocNext - selectDocString docs + dc <- selectDocString docs + pure $ lexLHsDocString <$> dc -- Step 2, process documentation comments in the export list: -- @@ -292,6 +295,12 @@ instance HasHaddock (Located HsModule) where , hsmodDecls = hsmodDecls' , hsmodHaddockModHeader = join @Maybe headerDocs } +lexHsDocString :: HsDocString -> HsDoc GhcPs +lexHsDocString = lexHsDoc parseIdentifier + +lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs +lexLHsDocString = fmap lexHsDocString + -- Only for module exports, not module imports. -- -- module M (a, b, c) where -- use on this [LIE GhcPs] @@ -700,7 +709,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_g_args = con_g_args', con_res_ty = con_res_ty' } ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> @@ -711,7 +720,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where ts' <- traverse addHaddockConDeclFieldTy ts pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = PrefixCon noTypeArgs ts' } InfixCon t1 t2 -> do t1' <- addHaddockConDeclFieldTy t1 @@ -719,14 +728,14 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where t2' <- addHaddockConDeclFieldTy t2 pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = InfixCon t1' t2' } RecCon (L l_rec flds) -> do con_doc' <- getConDoc (getLocA con_name) flds' <- traverse addHaddockConDeclField flds pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = con_doc', + con_doc = lexLHsDocString <$> con_doc', con_args = RecCon (L l_rec flds') } -- Keep track of documentation comments on the data constructor or any of its @@ -768,7 +777,7 @@ discardHasInnerDocs = fmap fst . runWriterT -- data/newtype declaration. getConDoc :: SrcSpan -- Location of the data constructor - -> ConHdkA (Maybe LHsDocString) + -> ConHdkA (Maybe (Located HsDocString)) getConDoc l = WriterT $ extendHdkA l $ liftHdkA $ do mDoc <- getPrevNextDoc l @@ -792,7 +801,7 @@ addHaddockConDeclField -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField (L l_fld fld) = WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do - cd_fld_doc <- getPrevNextDoc (locA l_fld) + cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld) return (L l_fld (fld { cd_fld_doc }), HasInnerDocs (isJust cd_fld_doc)) @@ -861,7 +870,7 @@ addConTrailingDoc l_sep = x <$ reportExtraDocs trailingDocs mk_doc_fld (L l' con_fld) = do doc <- selectDocString trailingDocs - return $ L l' (con_fld { cd_fld_doc = doc }) + return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc }) con_args' <- case con_args con_decl of x@(PrefixCon _ []) -> x <$ reportExtraDocs trailingDocs x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs @@ -872,7 +881,7 @@ addConTrailingDoc l_sep = return (RecCon (L l_rec flds')) return $ L l (con_decl{ con_args = con_args' }) else do - con_doc' <- selectDocString (con_doc con_decl `mcons` trailingDocs) + con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs)) return $ L l (con_decl{ con_doc = con_doc' }) _ -> panic "addConTrailingDoc: non-H98 ConDecl" @@ -1196,7 +1205,7 @@ data HdkSt = -- | Warnings accumulated in HdkM. data HdkWarn = HdkWarnInvalidComment (PsLocated HdkComment) - | HdkWarnExtraComment LHsDocString + | HdkWarnExtraComment (Located HsDocString) -- Restrict the range in which a HdkM computation will look up comments: -- @@ -1238,8 +1247,7 @@ takeHdkComments f = (items, other_comments) = foldr add_comment ([], []) comments_in_range remaining_comments = comments_before_range ++ other_comments ++ comments_after_range hdk_st' = hdk_st{ hdk_st_pending = remaining_comments } - in - (items, hdk_st') + in (items, hdk_st') where is_after StartOfFile _ = True is_after (StartLoc l) (L l_comment _) = bufSpanStart (psBufSpan l_comment) >= l @@ -1257,7 +1265,7 @@ takeHdkComments f = Nothing -> (items, hdk_comment : other_hdk_comments) -- Get the docnext or docprev comment for an AST node at the given source span. -getPrevNextDoc :: SrcSpan -> HdkM (Maybe LHsDocString) +getPrevNextDoc :: SrcSpan -> HdkM (Maybe (Located HsDocString)) getPrevNextDoc l = do let (l_start, l_end) = (srcSpanStart l, srcSpanEnd l) before_t = locRangeTo (getBufPos l_start) @@ -1271,7 +1279,7 @@ appendHdkWarning e = HdkM $ \_ hdk_st -> let hdk_st' = hdk_st { hdk_st_warnings = e : hdk_st_warnings hdk_st } in ((), hdk_st') -selectDocString :: [LHsDocString] -> HdkM (Maybe LHsDocString) +selectDocString :: [Located HsDocString] -> HdkM (Maybe (Located HsDocString)) selectDocString = select . filterOut (isEmptyDocString . unLoc) where select [] = return Nothing @@ -1280,7 +1288,16 @@ selectDocString = select . filterOut (isEmptyDocString . unLoc) reportExtraDocs extra_docs return (Just doc) -reportExtraDocs :: [LHsDocString] -> HdkM () +selectDoc :: forall a. [LHsDoc a] -> HdkM (Maybe (LHsDoc a)) +selectDoc = select . filterOut (isEmptyDocString . hsDocString . unLoc) + where + select [] = return Nothing + select [doc] = return (Just doc) + select (doc : extra_docs) = do + reportExtraDocs $ map (\(L l d) -> L l $ hsDocString d) extra_docs + return (Just doc) + +reportExtraDocs :: [Located HsDocString] -> HdkM () reportExtraDocs = traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc)) @@ -1297,13 +1314,14 @@ mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment) | indent_mismatch = Nothing | otherwise = - Just $ L (noAnnSrcSpan $ mkSrcSpanPs l_comment) $ + Just $ L (noAnnSrcSpan span) $ case hdk_comment of - HdkCommentNext doc -> DocCommentNext doc - HdkCommentPrev doc -> DocCommentPrev doc - HdkCommentNamed s doc -> DocCommentNamed s doc - HdkCommentSection n doc -> DocGroup n doc + HdkCommentNext doc -> DocCommentNext (L span $ lexHsDocString doc) + HdkCommentPrev doc -> DocCommentPrev (L span $ lexHsDocString doc) + HdkCommentNamed s doc -> DocCommentNamed s (L span $ lexHsDocString doc) + HdkCommentSection n doc -> DocGroup n (L span $ lexHsDocString doc) where + span = mkSrcSpanPs l_comment -- 'indent_mismatch' checks if the documentation comment has the exact -- indentation level expected by the parent node. -- @@ -1332,18 +1350,19 @@ mkDocDecl layout_info (L l_comment hdk_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) = case hdk_comment of - HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n doc) + HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n $ L span $ lexHsDocString doc) HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s) - HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc) + HdkCommentNext doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc) _ -> Nothing - where l = noAnnSrcSpan $ mkSrcSpanPs l_comment + where l = noAnnSrcSpan span + span = mkSrcSpanPs l_comment -mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString -mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc +mkDocNext :: PsLocated HdkComment -> Maybe (Located HsDocString) +mkDocNext (L l (HdkCommentNext doc)) = Just (L (mkSrcSpanPs l) doc) mkDocNext _ = Nothing -mkDocPrev :: PsLocated HdkComment -> Maybe LHsDocString -mkDocPrev (L l (HdkCommentPrev doc)) = Just $ L (mkSrcSpanPs l) doc +mkDocPrev :: PsLocated HdkComment -> Maybe (Located HsDocString) +mkDocPrev (L l (HdkCommentPrev doc)) = Just (L (mkSrcSpanPs l) doc) mkDocPrev _ = Nothing @@ -1396,6 +1415,7 @@ locRangeTo Strict.Nothing = mempty -- We'd rather only do the (>=40) check. So we reify the predicate to make -- sure we only check for the most restrictive bound. data LowerLocBound = StartOfFile | StartLoc !BufPos + deriving Show instance Semigroup LowerLocBound where StartOfFile <> l = l @@ -1424,6 +1444,7 @@ instance Monoid LowerLocBound where -- We'd rather only do the (<=20) check. So we reify the predicate to make -- sure we only check for the most restrictive bound. data UpperLocBound = EndOfFile | EndLoc !BufPos + deriving Show instance Semigroup UpperLocBound where EndOfFile <> l = l @@ -1442,6 +1463,7 @@ instance Monoid UpperLocBound where -- The semigroup instance corresponds to (&&). -- newtype ColumnBound = ColumnFrom Int -- n >= GHC.Types.SrcLoc.leftmostColumn + deriving Show instance Semigroup ColumnBound where ColumnFrom n <> ColumnFrom m = ColumnFrom (max n m) @@ -1456,9 +1478,9 @@ instance Monoid ColumnBound where * * ********************************************************************* -} -mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs +mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs mkLHsDocTy t Nothing = t -mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t doc) +mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t $ lexLHsDocString doc) getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc tele = diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs new file mode 100644 index 0000000000..b278e02cf3 --- /dev/null +++ b/compiler/GHC/Rename/Doc.hs @@ -0,0 +1,46 @@ +module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnLDocDecl, rnDocDecl ) where + +import GHC.Prelude + +import GHC.Tc.Types +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Tc.Utils.Monad (getGblEnv) +import GHC.Types.Avail +import GHC.Rename.Env + +rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn) +rnLHsDoc = traverse rnHsDoc + +rnLDocDecl :: LDocDecl GhcPs -> RnM (LDocDecl GhcRn) +rnLDocDecl = traverse rnDocDecl + +rnDocDecl :: DocDecl GhcPs -> RnM (DocDecl GhcRn) +rnDocDecl (DocCommentNext doc) = do + doc' <- rnLHsDoc doc + pure $ (DocCommentNext doc') +rnDocDecl (DocCommentPrev doc) = do + doc' <- rnLHsDoc doc + pure $ (DocCommentPrev doc') +rnDocDecl (DocCommentNamed n doc) = do + doc' <- rnLHsDoc doc + pure $ (DocCommentNamed n doc') +rnDocDecl (DocGroup i doc) = do + doc' <- rnLHsDoc doc + pure $ (DocGroup i doc') + +rnHsDoc :: WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn) +rnHsDoc (WithHsDocIdentifiers s ids) = do + gre <- tcg_rdr_env <$> getGblEnv + pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids)) + +rnHsDocIdentifiers :: GlobalRdrEnv + -> [Located RdrName] + -> [Located Name] +rnHsDocIdentifiers gre ns = concat + [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre) + | L l rdr_name <- ns + , c <- dataTcOccs rdr_name + ] diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 3525c71f1b..2440976b31 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -1583,7 +1583,7 @@ warnIfDeprecated gre@(GRE { gre_imp = iss }) extra | imp_mod == moduleName name_mod = Outputable.empty | otherwise = text ", but defined in" <+> ppr name_mod -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt +lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeprec iface gre = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, case gre_par gre of -- or its parent, is warn'd diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index edda60fbee..ae22cfa0cb 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -48,6 +48,7 @@ import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Driver.Session import GHC.Hs import GHC.Rename.Env +import GHC.Rename.Doc import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNamesN , checkShadowedRdrNames, warnForallIdentifier ) @@ -733,7 +734,8 @@ rnHsTyKi _ (HsSpliceTy _ sp) rnHsTyKi env (HsDocTy x ty haddock_doc) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsDocTy x ty' haddock_doc, fvs) } + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy x ty' haddock_doc', fvs) } -- See Note [Renaming HsCoreTys] rnHsTyKi env (XHsType ty) @@ -1271,7 +1273,8 @@ rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names ; let new_names = map (fmap (lookupField fl_env)) names ; (new_ty, fvs) <- rnLHsTyKi env ty - ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc) + ; haddock_doc' <- traverse rnLHsDoc haddock_doc + ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc') , fvs) } lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index b46528c6ed..9fbbcacdab 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -13,7 +13,7 @@ Main pass of renamer -} module GHC.Rename.Module ( - rnSrcDecls, addTcgDUs, findSplice + rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt ) where import GHC.Prelude @@ -27,6 +27,7 @@ import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Rename.HsType import GHC.Rename.Bind +import GHC.Rename.Doc import GHC.Rename.Env import GHC.Rename.Utils ( mapFvRn, bindLocalNames , checkDupRdrNamesN, bindLocalNamesFV @@ -205,6 +206,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; + rn_docs <- traverse rnLDocDecl docs ; last_tcg_env <- getGblEnv ; -- (I) Compute the results and return @@ -220,7 +222,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, hs_annds = rn_ann_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, - hs_docs = docs } ; + hs_docs = rn_docs } ; tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; @@ -264,7 +266,7 @@ gather them together. -} -- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn) rnSrcWarnDecls _ [] = return NoWarnings @@ -284,13 +286,23 @@ rnSrcWarnDecls bndr_set decls' -- ensures that the names are defined locally = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) rdr_names - ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } + ; txt' <- rnWarningTxt txt + ; return [(rdrNameOcc rdr, txt') | (rdr, _) <- names] } what = text "deprecation" warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls +rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) +rnWarningTxt (WarningTxt st wst) = do + wst' <- traverse (traverse rnHsDoc) wst + pure (WarningTxt st wst') +rnWarningTxt (DeprecatedTxt st wst) = do + wst' <- traverse (traverse rnHsDoc) wst + pure (DeprecatedTxt st wst') + + findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -1878,11 +1890,12 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- and the methods are already in scope ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs + ; docs' <- traverse rnLDocDecl docs ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = docs, tcdCExt = all_fvs }, + tcdDocs = docs', tcdCExt = all_fvs }, all_fvs ) } where cls_doc = ClassDeclCtx lcls @@ -2328,10 +2341,11 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs [ text "ex_tvs:" <+> ppr ex_tvs , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) + ; mb_doc' <- traverse rnLHsDoc mb_doc ; return (decl { con_ext = noAnn , con_name = new_name, con_ex_tvs = new_ex_tvs , con_mb_cxt = new_context, con_args = new_args - , con_doc = mb_doc + , con_doc = mb_doc' , con_forall = forall_ }, -- Remove when #18311 is fixed all_fvs) }} @@ -2372,10 +2386,11 @@ rnConDecl (ConDeclGADT { con_names = names ; traceRn "rnConDecl (ConDeclGADT)" (ppr names $$ ppr outer_bndrs') + ; new_mb_doc <- traverse rnLHsDoc mb_doc ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt , con_g_args = new_args, con_res_ty = new_res_ty - , con_doc = mb_doc }, + , con_doc = new_mb_doc }, all_fvs) } } rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index d2573b2b25..3a4cb78820 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -2163,14 +2163,14 @@ missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" -moduleWarn :: ModuleName -> WarningTxt -> SDoc +moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc moduleWarn mod (WarningTxt _ txt) = sep [ text "Module" <+> quotes (ppr mod) <> colon, - nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] + nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt) = sep [ text "Module" <+> quotes (ppr mod) <+> text "is deprecated:", - nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] + nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] packageImportErr :: TcRnMessage packageImportErr diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 9f2c257435..bf6227737f 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -108,6 +108,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.DSet import GHC.Types.TyThing import GHC.Types.BreakInfo +import GHC.Types.Unique.Map import GHC.Unit import GHC.Unit.Module.Graph @@ -121,7 +122,6 @@ import Data.Either import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (find,intercalate) -import qualified Data.Map as Map import Control.Monad import Control.Monad.Catch as MC import Data.Array @@ -909,7 +909,7 @@ parseName str = withSession $ \hsc_env -> liftIO $ getDocs :: GhcMonad m => Name - -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString)) + -> m (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))) -- TODO: What about docs for constructors etc.? getDocs name = withSession $ \hsc_env -> do @@ -919,14 +919,14 @@ getDocs name = if isInteractiveModule mod then pure (Left InteractiveName) else do - ModIface { mi_doc_hdr = mb_doc_hdr - , mi_decl_docs = DeclDocMap dmap - , mi_arg_docs = ArgDocMap amap - } <- liftIO $ hscGetModuleInterface hsc_env mod - if isNothing mb_doc_hdr && Map.null dmap && Map.null amap - then pure (Left (NoDocsInIface mod compiled)) - else pure (Right ( Map.lookup name dmap - , Map.findWithDefault mempty name amap)) + iface <- liftIO $ hscGetModuleInterface hsc_env mod + case mi_docs iface of + Nothing -> pure (Left (NoDocsInIface mod compiled)) + Just Docs { docs_decls = decls + , docs_args = args + } -> + pure (Right ( lookupUniqMap decls name + , fromMaybe mempty $ lookupUniqMap args name)) where compiled = -- TODO: Find a more direct indicator. @@ -935,16 +935,12 @@ getDocs name = UnhelpfulLoc {} -> True -- | Failure modes for 'getDocs'. - --- TODO: Find a way to differentiate between modules loaded without '-haddock' --- and modules that contain no docs. data GetDocsFailure -- | 'nameModule_maybe' returned 'Nothing'. = NameHasNoModule Name - -- | This is probably because the module was loaded without @-haddock@, - -- but it's also possible that the entire module contains no documentation. + -- | The module was loaded without @-haddock@, | NoDocsInIface Module Bool -- ^ 'True': The module was compiled. @@ -958,11 +954,6 @@ instance Outputable GetDocsFailure where quotes (ppr name) <+> text "has no module where we could look for docs." ppr (NoDocsInIface mod compiled) = vcat [ text "Can't find any documentation for" <+> ppr mod <> char '.' - , text "This is probably because the module was" - <+> text (if compiled then "compiled" else "loaded") - <+> text "without '-haddock'," - , text "but it's also possible that the module contains no documentation." - , text "" , if compiled then text "Try re-compiling with '-haddock'." else text "Try running ':set -haddock' and :load the file again." diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index 079bbd5df5..fcae57f975 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -73,14 +73,18 @@ import GHC.Tc.Solver.Monad ( runTcSEarlyAbort ) import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) import GHC.HsToCore.Docs ( extractDocs ) -import qualified Data.Map as Map -import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) +import GHC.Hs.Doc import GHC.Unit.Module.ModIface ( ModIface_(..) ) -import GHC.Iface.Load ( loadInterfaceForNameMaybe ) +import GHC.Iface.Load ( loadInterfaceForName ) import GHC.Builtin.Utils (knownKeyNames) import GHC.Tc.Errors.Hole.FitTypes +import qualified Data.Set as Set +import GHC.Types.SrcLoc +import GHC.Utils.Trace (warnPprTrace) +import GHC.Data.FastString (unpackFS) +import GHC.Types.Unique.Map {- @@ -456,21 +460,40 @@ addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] addHoleFitDocs fits = do { showDocs <- goptM Opt_ShowDocsOfHoleFits ; if showDocs - then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs - ; mapM (upd lclDocs) fits } + then do { dflags <- getDynFlags + ; mb_local_docs <- extractDocs dflags =<< getGblEnv + ; (mods_without_docs, fits') <- mapAccumM (upd mb_local_docs) Set.empty fits + ; report mods_without_docs + ; return fits' } else return fits } where msg = text "GHC.Tc.Errors.Hole addHoleFitDocs" - lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap }) - = Map.lookup name dmap - upd lclDocs fit@(HoleFit {hfCand = cand}) = - do { let name = getName cand - ; doc <- if hfIsLcl fit - then pure (Map.lookup name lclDocs) - else do { mbIface <- loadInterfaceForNameMaybe msg name - ; return $ mbIface >>= lookupInIface name } - ; return $ fit {hfDoc = doc} } - upd _ fit = return fit + upd mb_local_docs mods_without_docs fit@(HoleFit {hfCand = cand}) = + let name = getName cand in + do { mb_docs <- if hfIsLcl fit + then pure mb_local_docs + else mi_docs <$> loadInterfaceForName msg name + ; case mb_docs of + { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, fit) + ; Just docs -> do + { let doc = lookupUniqMap (docs_decls docs) name + ; return $ (mods_without_docs, fit {hfDoc = map hsDocString <$> doc}) }}} + upd _ mods_without_docs fit = pure (mods_without_docs, fit) + nameOrigin name = case nameModule_maybe name of + Just m -> Right m + Nothing -> + Left $ case nameSrcLoc name of + RealSrcLoc r _ -> unpackFS $ srcLocFile r + UnhelpfulLoc s -> unpackFS $ s + report mods = do + { let warning = + text "WARNING: Couldn't find any documentation for the following modules:" $+$ + nest 2 + (fsep (punctuate comma + (either text ppr <$> Set.toList mods)) $+$ + text "Make sure the modules are compiled with '-haddock'.") + ; warnPprTrace (not $ Set.null mods)"addHoleFitDocs" warning (pure ()) + } -- For pretty printing hole fits, we display the name and type of the fit, -- with added '_' to represent any extra arguments in case of a non-zero @@ -517,9 +540,7 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = then occDisp <+> tyApp else tyAppVars docs = case hfDoc of - Just d -> text "{-^" <> - (vcat . map text . lines . unpackHDS) d - <> text "-}" + Just d -> pprHsDocStrings d _ -> empty funcInfo = ppWhen (has hfMatches && sTy) $ text "where" <+> occDisp <+> tyDisp diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs index 077bdaab18..72cb54bec2 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -87,7 +87,7 @@ data HoleFit = , hfWrap :: [TcType] -- ^ The wrapper for the match. , hfMatches :: [TcType] -- ^ What the refinement variables got matched with, if anything - , hfDoc :: Maybe HsDocString + , hfDoc :: Maybe [HsDocString] -- ^ Documentation of this HoleFit, if available. } | RawHoleFit SDoc diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot index c6141d8897..8943c3f0a2 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot @@ -25,6 +25,6 @@ data HoleFit = , hfRefLvl :: Int , hfWrap :: [TcType] , hfMatches :: [TcType] - , hfDoc :: Maybe HsDocString + , hfDoc :: Maybe [HsDocString] } | RawHoleFit SDoc diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 2055b3101c..26b765a9d1 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -44,6 +44,7 @@ import Control.Monad import GHC.Driver.Session import GHC.Parser.PostProcess ( setRdrNameSpace ) import Data.Either ( partitionEithers ) +import GHC.Rename.Doc {- ************************************************************************ @@ -316,12 +317,12 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod , ( L loc (IEModuleContents noExtField lmod) , new_exports))) } - exports_from_item acc@(ExportAccum occs mods) (L loc ie) - | Just new_ie <- lookup_doc_ie ie - = return (Just (acc, (L loc new_ie, []))) - - | otherwise - = do (new_ie, avail) <- lookup_ie ie + exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do + m_new_ie <- lookup_doc_ie ie + case m_new_ie of + Just new_ie -> return (Just (acc, (L loc new_ie, []))) + Nothing -> do + (new_ie, avail) <- lookup_ie ie if isUnboundName (ieName new_ie) then return Nothing -- Avoid error cascade else do @@ -396,11 +397,15 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod return (L (locA l) name, non_flds, flds) ------------- - lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn) - lookup_doc_ie (IEGroup _ lev doc) = Just (IEGroup noExtField lev doc) - lookup_doc_ie (IEDoc _ doc) = Just (IEDoc noExtField doc) - lookup_doc_ie (IEDocNamed _ str) = Just (IEDocNamed noExtField str) - lookup_doc_ie _ = Nothing + lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn)) + lookup_doc_ie (IEGroup _ lev doc) = do + doc' <- rnLHsDoc doc + pure $ Just (IEGroup noExtField lev doc') + lookup_doc_ie (IEDoc _ doc) = do + doc' <- rnLHsDoc doc + pure $ Just (IEDoc noExtField doc') + lookup_doc_ie (IEDocNamed _ str) = pure $ Just (IEDocNamed noExtField str) + lookup_doc_ie _ = pure Nothing -- In an export item M.T(A,B,C), we want to treat the uses of -- A,B,C as if they were M.A, M.B, M.C diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index c42dd689fa..6860eba567 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -10,6 +10,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE NamedFieldPuns #-} {- (c) The University of Glasgow 2006 @@ -110,6 +111,7 @@ import GHC.Types.Error import GHC.Types.Fixity as Hs import GHC.Types.Annotations import GHC.Types.Name +import GHC.Types.Unique.Map import GHC.Serialized import GHC.Unit.Finder @@ -154,6 +156,9 @@ import qualified Data.Map as Map import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) +import GHC.Parser.HaddockLex (lexHsDoc) +import GHC.Parser (parseIdentifier) +import GHC.Rename.Doc (rnHsDoc) {- ************************************************************************ @@ -1307,7 +1312,10 @@ instance TH.Quasi TcM where unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Can't add documentation to" <+> ppr_loc doc_loc <+> text "as it isn't inside the current module" - updTcRef th_doc_var (Map.insert resolved_doc_loc s) + let ds = mkGeneratedHsDocString s + hd = lexHsDoc parseIdentifier ds + hd' <- rnHsDoc hd + updTcRef th_doc_var (Map.insert resolved_doc_loc hd') where resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i @@ -1331,40 +1339,41 @@ instance TH.Quasi TcM where qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i qGetDoc TH.ModuleDoc = do - (moduleDoc, _, _) <- getGblEnv >>= extractDocs - return (fmap unpackHDS moduleDoc) + df <- getDynFlags + docs <- getGblEnv >>= extractDocs df + return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) -- | Looks up documentation for a declaration in first the current module, -- otherwise tries to find it in another module via 'hscGetModuleInterface'. lookupDeclDoc :: Name -> TcM (Maybe String) lookupDeclDoc nm = do - (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs - fam_insts <- tcg_fam_insts <$> getGblEnv - traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts) - case Map.lookup nm declDocs of - Just doc -> pure $ Just (unpackHDS doc) + df <- getDynFlags + Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df + case lookupUniqMap docs_decls nm of + Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc) Nothing -> do -- Wasn't in the current module. Try searching other external ones! mIface <- getExternalModIface nm case mIface of - Nothing -> pure Nothing - Just ModIface { mi_decl_docs = DeclDocMap dmap } -> - pure $ unpackHDS <$> Map.lookup nm dmap + Just ModIface { mi_docs = Just Docs{docs_decls = dmap} } -> + pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm + _ -> pure Nothing -- | Like 'lookupDeclDoc', looks up documentation for a function argument. If -- it can't find any documentation for a function in this module, it tries to -- find it in another module. lookupArgDoc :: Int -> Name -> TcM (Maybe String) lookupArgDoc i nm = do - (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs - case Map.lookup nm argDocs of - Just m -> pure $ unpackHDS <$> IntMap.lookup i m + df <- getDynFlags + Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df + case lookupUniqMap argDocs nm of + Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m Nothing -> do mIface <- getExternalModIface nm case mIface of - Nothing -> pure Nothing - Just ModIface { mi_arg_docs = ArgDocMap amap } -> - pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i) + Just ModIface { mi_docs = Just Docs{docs_args = amap} } -> + pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i) + _ -> pure Nothing -- | Returns the module a Name belongs to, if it is isn't local. getExternalModIface :: Name -> TcM (Maybe ModIface) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index dca5bce99e..e690d1e5a2 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -95,6 +95,7 @@ import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module +import GHC.Rename.Doc import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) import GHC.Iface.Type ( ShowForAllFlag(..) ) @@ -292,22 +293,23 @@ tcRnModuleTcRnM hsc_env mod_sum tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env all_imports - ; -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - -- Make sure to do this before 'tcRnSrcDecls', because we need the - -- module header when we're splicing TH, since it can be accessed via - -- 'getDoc'. - tcg_env <- return (tcg_env - { tcg_doc_hdr = maybe_doc_hdr }) - + -- Put a version of the header without identifier info into the tcg_env + -- Make sure to do this before 'tcRnSrcDecls', because we need the + -- module header when we're splicing TH, since it can be accessed via + -- 'getDoc'. + -- We will rename it properly after renaming everything else so that + -- haddock can link the identifiers + ; tcg_env <- return (tcg_env + { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str []) + <$> maybe_doc_hdr }) ; -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns - let { tcg_env1 = case mod_deprec of - Just (L _ txt) -> - tcg_env {tcg_warns = WarnAll txt} - Nothing -> tcg_env - } + ; tcg_env1 <- case mod_deprec of + Just (L _ txt) -> do { txt' <- rnWarningTxt txt + ; pure $ tcg_env {tcg_warns = WarnAll txt'} + } + Nothing -> pure tcg_env ; setGblEnv tcg_env1 $ do { -- Rename and type check the declarations traceRn "rn1a" empty @@ -337,11 +339,17 @@ tcRnModuleTcRnM hsc_env mod_sum -- because the latter might add new bindings for -- boot_dfuns, which may be mentioned in imported -- unfoldings. - -- Report unused names + ; -- Report unused names -- Do this /after/ typeinference, so that when reporting -- a function with no type signature we can give the -- inferred type - reportUnusedNames tcg_env hsc_src + ; reportUnusedNames tcg_env hsc_src + + -- Rename the module header properly after we have renamed everything else + ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr; + ; tcg_env <- return (tcg_env + { tcg_doc_hdr = maybe_doc_hdr }) + ; -- add extra source files to tcg_dependent_files addDependentFiles src_files -- Ensure plugins run with the same tcg_env that we pass in @@ -3174,7 +3182,7 @@ runRenamerPlugin gbl_env hs_group = do -- exception/signal an error. type RenamedStuff = (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString)) + Maybe (LHsDoc GhcRn))) -- | Extract the renamed information from TcGblEnv. getRenamedStuff :: TcGblEnv -> RenamedStuff diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 776d0f40fb..d837b629ec 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -591,7 +591,7 @@ data TcGblEnv tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids - tcg_warns :: Warnings, -- ...Warnings and deprecations + tcg_warns :: (Warnings GhcRn), -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_tcs :: [TyCon], -- ...TyCons and Classes tcg_ksigs :: NameSet, -- ...Top-level TyCon names that *lack* a signature @@ -601,7 +601,7 @@ data TcGblEnv tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports tcg_patsyns :: [PatSyn], -- ...Pattern synonyms - tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs + tcg_doc_hdr :: Maybe (LHsDoc GhcRn), -- ^ Maybe Haddock header docs tcg_hpc :: !AnyHpcUsage, -- ^ @True@ if any part of the -- prog uses hpc instrumentation. -- NB. BangPattern is to fix a leak, see #15111 @@ -1873,4 +1873,4 @@ data DocLoc = DeclDoc Name -- | The current collection of docs that Template Haskell has built up via -- putDoc. -type THDocs = Map DocLoc String +type THDocs = Map DocLoc (HsDoc GhcRn) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 7c270e39bd..993f458731 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -24,7 +24,7 @@ module GHC.Tc.Utils.Env( tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, ioLookupDataCon, + lookupGlobal, lookupGlobal_maybe, ioLookupDataCon, addTypecheckedBinds, -- Local environment diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 9f4cedbb39..2e234c383b 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -16,6 +16,7 @@ types that {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index 6a2bc2c814..a6f27f38e6 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -82,6 +82,7 @@ module GHC.Types.SrcLoc ( getLoc, unLoc, unRealSrcSpan, getRealSrcSpan, pprLocated, + pprLocatedAlways, -- ** Modifying Located mapLoc, @@ -106,6 +107,7 @@ module GHC.Types.SrcLoc ( psSpanEnd, mkSrcSpanPs, combineRealSrcSpans, + psLocatedToLocated, -- * Layout information LayoutInfo(..), @@ -222,7 +224,7 @@ data RealSrcLoc -- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock -- comments with parts of the AST using location information (#17544). newtype BufPos = BufPos { bufPos :: Int } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Data) -- | Source Location data SrcLoc @@ -371,7 +373,7 @@ data RealSrcSpan -- | StringBuffer Source Span data BufSpan = BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Data) instance Semigroup BufSpan where BufSpan start1 end1 <> BufSpan start2 end2 = @@ -730,7 +732,7 @@ pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data GenLocated l e = L l e - deriving (Eq, Ord, Data, Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable) type Located = GenLocated SrcSpan type RealLocated = GenLocated RealSrcSpan @@ -798,6 +800,12 @@ pprLocated (L l e) = whenPprDebug (braces (ppr l)) $$ ppr e +-- | Always prints the location, even without -dppr-debug +pprLocatedAlways :: (Outputable l, Outputable e) => GenLocated l e -> SDoc +pprLocatedAlways (L l e) = + braces (ppr l) + $$ ppr e + {- ************************************************************************ * * @@ -865,10 +873,13 @@ data PsLoc data PsSpan = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Data) type PsLocated = GenLocated PsSpan +psLocatedToLocated :: PsLocated a -> Located a +psLocatedToLocated (L sp a) = L (mkSrcSpanPs sp) a + advancePsLoc :: PsLoc -> Char -> PsLoc advancePsLoc (PsLoc real_loc buf_loc) c = PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc) diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs index dfbc13fe4f..18d3b2a73a 100644 --- a/compiler/GHC/Types/Unique/Map.hs +++ b/compiler/GHC/Types/Unique/Map.hs @@ -41,7 +41,8 @@ module GHC.Types.Unique.Map ( lookupWithDefaultUniqMap, anyUniqMap, allUniqMap, - nonDetEltsUniqMap + nonDetEltsUniqMap, + nonDetFoldUniqMap -- Non-deterministic functions omitted ) where @@ -208,3 +209,6 @@ allUniqMap f (UniqMap m) = allUFM (f . snd) m nonDetEltsUniqMap :: UniqMap k a -> [(k, a)] nonDetEltsUniqMap (UniqMap m) = nonDetEltsUFM m + +nonDetFoldUniqMap :: ((k, a) -> b -> b) -> b -> UniqMap k a -> b +nonDetFoldUniqMap go z (UniqMap m) = foldUFM go z m diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs index 4fc683d844..d54e836d71 100644 --- a/compiler/GHC/Unit/Module/ModGuts.hs +++ b/compiler/GHC/Unit/Module/ModGuts.hs @@ -72,7 +72,7 @@ data ModGuts mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_foreign_files :: ![(ForeignSrcLang, FilePath)], -- ^ Files to be compiled with the C compiler - mg_warns :: !Warnings, -- ^ Warnings declared in the module + mg_warns :: !(Warnings GhcRn), -- ^ Warnings declared in the module mg_anns :: [Annotation], -- ^ Annotations declared in this module mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module @@ -97,9 +97,7 @@ data ModGuts -- See Note [Trust Own Package] -- in "GHC.Rename.Names" - mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. - mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. - mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. + mg_docs :: !(Maybe Docs) -- ^ Documentation. } mg_mnwib :: ModGuts -> ModuleNameWithIsBoot diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs index db7c4ce362..5a3cfe71c9 100644 --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -109,7 +109,7 @@ data ModIfaceBackend = ModIfaceBackend -- other fields and are not put into the interface file. -- Not really produced by the backend but there is no need to create them -- any earlier. - , mi_warn_fn :: !(OccName -> Maybe WarningTxt) + , mi_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn)) -- ^ Cached lookup for 'mi_warns' , mi_fix_fn :: !(OccName -> Maybe Fixity) -- ^ Cached lookup for 'mi_fixities' @@ -184,7 +184,7 @@ data ModIface_ (phase :: ModIfacePhase) -- ^ Fixities -- NOT STRICT! we read this field lazily from the interface file - mi_warns :: Warnings, + mi_warns :: (Warnings GhcRn), -- ^ Warnings -- NOT STRICT! we read this field lazily from the interface file @@ -235,14 +235,11 @@ data ModIface_ (phase :: ModIfacePhase) -- See Note [Trust Own Package] in GHC.Rename.Names mi_complete_matches :: ![IfaceCompleteMatch], - mi_doc_hdr :: Maybe HsDocString, - -- ^ Module header. - - mi_decl_docs :: DeclDocMap, - -- ^ Docs on declarations. - - mi_arg_docs :: ArgDocMap, - -- ^ Docs on arguments. + mi_docs :: Maybe Docs, + -- ^ Docstrings and related data for use by haddock, the ghci + -- @:doc@ command, and other tools. + -- + -- @Just _@ @<=>@ the module was built with @-haddock@. mi_final_exts :: !(IfaceBackendExts phase), -- ^ Either `()` or `ModIfaceBackend` for @@ -359,9 +356,7 @@ instance Binary ModIface where mi_trust = trust, mi_trust_pkg = trust_pkg, mi_complete_matches = complete_matches, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, + mi_docs = docs, mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we -- can deal with it's pointer in the header -- when we write the actual file @@ -405,9 +400,7 @@ instance Binary ModIface where put_ bh trust put_ bh trust_pkg put_ bh complete_matches - lazyPut bh doc_hdr - lazyPut bh decl_docs - lazyPut bh arg_docs + lazyPutMaybe bh docs get bh = do mod <- get bh @@ -438,9 +431,7 @@ instance Binary ModIface where trust <- get bh trust_pkg <- get bh complete_matches <- get bh - doc_hdr <- lazyGet bh - decl_docs <- lazyGet bh - arg_docs <- lazyGet bh + docs <- lazyGetMaybe bh return (ModIface { mi_module = mod, mi_sig_of = sig_of, @@ -464,9 +455,7 @@ instance Binary ModIface where mi_trust_pkg = trust_pkg, -- And build the cached values mi_complete_matches = complete_matches, - mi_doc_hdr = doc_hdr, - mi_decl_docs = decl_docs, - mi_arg_docs = arg_docs, + mi_docs = docs, mi_ext_fields = emptyExtensibleFields, -- placeholder because this is dealt -- with specially when the file is read mi_final_exts = ModIfaceBackend { @@ -510,9 +499,7 @@ emptyPartialModIface mod mi_trust = noIfaceTrustInfo, mi_trust_pkg = False, mi_complete_matches = [], - mi_doc_hdr = Nothing, - mi_decl_docs = emptyDeclDocMap, - mi_arg_docs = emptyArgDocMap, + mi_docs = Nothing, mi_final_exts = (), mi_ext_fields = emptyExtensibleFields } @@ -554,11 +541,11 @@ emptyIfaceHashCache _occ = Nothing -- avoid major space leaks. instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 - f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24 f25) = + f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 - `seq` rnf f24 `seq` f25 `seq` () + `seq` () instance NFData (ModIfaceBackend) where rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs index d8847be72c..6936702b2a 100644 --- a/compiler/GHC/Unit/Module/Warnings.hs +++ b/compiler/GHC/Unit/Module/Warnings.hs @@ -1,4 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} -- | Warnings for a module module GHC.Unit.Module.Warnings @@ -16,25 +20,31 @@ import GHC.Prelude import GHC.Types.SourceText import GHC.Types.Name.Occurrence import GHC.Types.SrcLoc +import GHC.Hs.Doc +import GHC.Hs.Extension import GHC.Utils.Outputable import GHC.Utils.Binary +import Language.Haskell.Syntax.Extension + import Data.Data -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt +data WarningTxt pass = WarningTxt (Located SourceText) - [Located StringLiteral] + [Located (WithHsDocIdentifiers StringLiteral pass)] | DeprecatedTxt (Located SourceText) - [Located StringLiteral] - deriving (Eq, Data) + [Located (WithHsDocIdentifiers StringLiteral pass)] + +deriving instance Eq (IdP pass) => Eq (WarningTxt pass) +deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) -instance Outputable WarningTxt where +instance Outputable (WarningTxt pass) where ppr (WarningTxt lsrc ws) = case unLoc lsrc of NoSourceText -> pp_ws ws @@ -45,7 +55,7 @@ instance Outputable WarningTxt where NoSourceText -> pp_ws ds SourceText src -> text src <+> pp_ws ds <+> text "#-}" -instance Binary WarningTxt where +instance Binary (WarningTxt GhcRn) where put_ bh (WarningTxt s w) = do putByte bh 0 put_ bh s @@ -66,7 +76,7 @@ instance Binary WarningTxt where return (DeprecatedTxt s d) -pp_ws :: [Located StringLiteral] -> SDoc +pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws = text "[" @@ -74,19 +84,19 @@ pp_ws ws <+> text "]" -pprWarningTxtForMsg :: WarningTxt -> SDoc +pprWarningTxtForMsg :: WarningTxt p -> SDoc pprWarningTxtForMsg (WarningTxt _ ws) - = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) + = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws)) pprWarningTxtForMsg (DeprecatedTxt _ ds) = text "Deprecated:" <+> - doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) + doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ds)) -- | Warning information for a module -data Warnings +data Warnings pass = NoWarnings -- ^ Nothing deprecated - | WarnAll WarningTxt -- ^ Whole module deprecated - | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated + | WarnAll (WarningTxt pass) -- ^ Whole module deprecated + | WarnSome [(OccName,WarningTxt pass)] -- ^ Some specific things deprecated -- Only an OccName is needed because -- (1) a deprecation always applies to a binding @@ -108,9 +118,10 @@ data Warnings -- -- this is in contrast with fixity declarations, where we need to map -- a Name to its fixity declaration. - deriving( Eq ) -instance Binary Warnings where +deriving instance Eq (IdP pass) => Eq (Warnings pass) + +instance Binary (Warnings GhcRn) where put_ bh NoWarnings = putByte bh 0 put_ bh (WarnAll t) = do putByte bh 1 @@ -129,15 +140,15 @@ instance Binary Warnings where return (WarnSome aa) -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' -mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt +mkIfaceWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p) mkIfaceWarnCache NoWarnings = \_ -> Nothing mkIfaceWarnCache (WarnAll t) = \_ -> Just t mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) -emptyIfaceWarnCache :: OccName -> Maybe WarningTxt +emptyIfaceWarnCache :: OccName -> Maybe (WarningTxt p) emptyIfaceWarnCache _ = Nothing -plusWarns :: Warnings -> Warnings -> Warnings +plusWarns :: Warnings p -> Warnings p -> Warnings p plusWarns d NoWarnings = d plusWarns NoWarnings d = d plusWarns _ (WarnAll t) = WarnAll t diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 36931b7b1f..15071c1b37 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -66,6 +66,8 @@ module GHC.Utils.Binary -- * Lazy Binary I/O lazyGet, lazyPut, + lazyGetMaybe, + lazyPutMaybe, -- * User data UserData(..), getUserData, setUserData, @@ -94,15 +96,19 @@ import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Unsafe as BS import Data.IORef import Data.Char ( ord, chr ) +import Data.List.NonEmpty ( NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Set ( Set ) +import qualified Data.Set as Set import Data.Time import Data.List (unfoldr) -import Data.Set (Set) -import qualified Data.Set as Set import Control.Monad ( when, (<$!>), unless, forM_ ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap #if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr ( unsafeWithForeignPtr ) #endif @@ -635,9 +641,15 @@ instance Binary a => Binary [a] where loop n = do a <- get bh; as <- loop (n-1); return (a:as) loop len -instance Binary a => Binary (Set a) where - put_ bh a = put_ bh (Set.toAscList a) - get bh = Set.fromDistinctAscList <$> get bh +-- | This instance doesn't rely on the determinism of the keys' 'Ord' instance, +-- so it works e.g. for 'Name's too. +instance (Binary a, Ord a) => Binary (Set a) where + put_ bh s = put_ bh (Set.toList s) + get bh = Set.fromList <$> get bh + +instance Binary a => Binary (NonEmpty a) where + put_ bh = put_ bh . NonEmpty.toList + get bh = NonEmpty.fromList <$> get bh instance (Ix a, Binary a, Binary b) => Binary (Array a b) where put_ bh arr = do @@ -927,6 +939,25 @@ lazyGet bh = do seekBin bh p -- skip over the object for now return a +-- | Serialize the constructor strictly but lazily serialize a value inside a +-- 'Just'. +-- +-- This way we can check for the presence of a value without deserializing the +-- value itself. +lazyPutMaybe :: Binary a => BinHandle -> Maybe a -> IO () +lazyPutMaybe bh Nothing = putWord8 bh 0 +lazyPutMaybe bh (Just x) = do + putWord8 bh 1 + lazyPut bh x + +-- | Deserialize a value serialized by 'lazyPutMaybe'. +lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a) +lazyGetMaybe bh = do + h <- getWord8 bh + case h of + 0 -> pure Nothing + _ -> Just <$> lazyGet bh + -- ----------------------------------------------------------------------------- -- UserData -- ----------------------------------------------------------------------------- @@ -1323,3 +1354,11 @@ instance Binary SrcSpan where return (RealSrcSpan ss sb) _ -> do s <- get bh return (UnhelpfulSpan s) + +-------------------------------------------------------------------------------- +-- Instances for the containers package +-------------------------------------------------------------------------------- + +instance (Binary v) => Binary (IntMap v) where + put_ bh m = put_ bh (IntMap.toList m) + get bh = IntMap.fromList <$> get bh diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index f6a07ad0ae..06a784dba7 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -29,6 +29,7 @@ module GHC.Utils.Misc ( mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, filterOut, partitionWith, + mapAccumM, dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, @@ -543,6 +544,15 @@ mapLastM _ [] = panic "mapLastM: empty list" mapLastM f [x] = (\x' -> [x']) <$> f x mapLastM f (x:xs) = (x:) <$> mapLastM f xs +mapAccumM :: (Monad m) => (r -> a -> m (r, b)) -> r -> [a] -> m (r, [b]) +mapAccumM f = go + where + go acc [] = pure (acc,[]) + go acc (x:xs) = do + (acc',y) <- f acc x + (acc'',ys) <- go acc' xs + pure (acc'', y:ys) + whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () whenNonEmpty (x:xs) f = f (x :| xs) diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index b668d7fbff..64e9a0cc4e 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ViewPatterns #-} @@ -150,7 +151,8 @@ data HsDecl p | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration -- (Includes quasi-quotes) - | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration + | DocD (XDocD p) (DocDecl p) -- ^ Documentation comment + -- declaration | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration | XHsDecl !(XXHsDecl p) @@ -1064,8 +1066,8 @@ data ConDecl pass , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix , con_res_ty :: LHsType pass -- ^ Result type - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. + , con_doc :: Maybe (LHsDoc pass) -- ^ A possible Haddock + -- comment. } | ConDeclH98 @@ -1081,8 +1083,7 @@ data ConDecl pass , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. + , con_doc :: Maybe (LHsDoc pass) -- ^ A possible Haddock comment. } | XConDecl !(XXConDecl pass) @@ -1706,21 +1707,22 @@ pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -} -- | Located Documentation comment Declaration -type LDocDecl pass = XRec pass (DocDecl) +type LDocDecl pass = XRec pass (DocDecl pass) -- | Documentation comment Declaration -data DocDecl - = DocCommentNext HsDocString - | DocCommentPrev HsDocString - | DocCommentNamed String HsDocString - | DocGroup Int HsDocString - deriving Data +data DocDecl pass + = DocCommentNext (LHsDoc pass) + | DocCommentPrev (LHsDoc pass) + | DocCommentNamed String (LHsDoc pass) + | DocGroup Int (LHsDoc pass) + +deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) -- Okay, I need to reconstruct the document comments, but for now: -instance Outputable DocDecl where +instance Outputable (DocDecl name) where ppr _ = text "<document comment>" -docDeclDoc :: DocDecl -> HsDocString +docDeclDoc :: DocDecl pass -> LHsDoc pass docDeclDoc (DocCommentNext d) = d docDeclDoc (DocCommentPrev d) = d docDeclDoc (DocCommentNamed _ d) = d @@ -1751,9 +1753,10 @@ data WarnDecls pass = Warnings { wd_ext :: XWarnings pass type LWarnDecl pass = XRec pass (WarnDecl pass) -- | Warning pragma Declaration -data WarnDecl pass = Warning (XWarning pass) [LIdP pass] WarningTxt +data WarnDecl pass = Warning (XWarning pass) [LIdP pass] (WarningTxt pass) | XWarnDecl !(XXWarnDecl pass) + {- ************************************************************************ * * diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 10c2c03b48..e7c35f93c1 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -841,7 +841,7 @@ data HsType pass -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsDocTy (XDocTy pass) - (LHsType pass) LHsDocString -- A documented type + (LHsType pass) (LHsDoc pass) -- A documented type -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation @@ -1046,7 +1046,7 @@ data ConDeclField pass -- Record fields have Haddock docs on them cd_fld_names :: [LFieldOcc pass], -- ^ See Note [ConDeclField passs] cd_fld_type :: LBangType pass, - cd_fld_doc :: Maybe LHsDocString } + cd_fld_doc :: Maybe (LHsDoc pass)} -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 5a3794ee37..c02e56b291 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -420,6 +420,7 @@ Library GHC.Hs.Binds GHC.Hs.Decls GHC.Hs.Doc + GHC.Hs.DocString GHC.Hs.Dump GHC.Hs.Expr GHC.Hs.Syn.Type @@ -502,6 +503,7 @@ Library GHC.Parser.Errors.Types GHC.Parser.Header GHC.Parser.Lexer + GHC.Parser.HaddockLex GHC.Parser.PostProcess GHC.Parser.PostProcess.Haddock GHC.Parser.Types @@ -524,6 +526,7 @@ Library GHC.Plugins GHC.Prelude GHC.Rename.Bind + GHC.Rename.Doc GHC.Rename.Env GHC.Rename.Expr GHC.Rename.Fixity @@ -1245,6 +1245,7 @@ sdist-ghc-prep-tree : $(eval $(call sdist-ghc-file,compiler,stage2,.,GHC/Cmm/Lexer,x)) $(eval $(call sdist-ghc-file,compiler,stage2,.,GHC/Cmm/Parser,y)) $(eval $(call sdist-ghc-file,compiler,stage2,.,GHC/Parser/Lexer,x)) +$(eval $(call sdist-ghc-file,compiler,stage2,.,GHC/Parser/HaddockLex,x)) $(eval $(call sdist-ghc-file,compiler,stage2,.,GHC/Parser,y)) $(eval $(call sdist-ghc-file,utils/hpc,dist-install,,HpcParser,y)) $(eval $(call sdist-ghc-file,utils/genprimopcode,dist,,Lexer,x)) diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 4043f3e247..76d714c3e6 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1902,9 +1902,9 @@ docCmd s = do data DocComponents = DocComponents - { docs :: Maybe HsDocString -- ^ subject's haddocks + { docs :: Maybe [HsDoc GhcRn] -- ^ subject's haddocks , sigAndLoc :: Maybe SDoc -- ^ type signature + category + location - , argDocs :: IntMap HsDocString -- ^ haddocks for arguments + , argDocs :: IntMap (HsDoc GhcRn) -- ^ haddocks for arguments } buildDocComponents :: GHC.GhcMonad m => String -> Name -> m DocComponents @@ -1945,7 +1945,7 @@ pprDocs docs | otherwise = pprDoc <$> nonEmptyDocs where empty DocComponents{docs = mb_decl_docs, argDocs = arg_docs} - = isNothing mb_decl_docs && null arg_docs + = maybe True null mb_decl_docs && null arg_docs nonEmptyDocs = filter (not . empty) docs -- TODO: also print arg docs. @@ -1958,7 +1958,7 @@ pprDoc DocComponents{sigAndLoc = mb_sig_loc, docs = mb_decl_docs} = where formatDoc doc = vcat [ fromMaybe empty mb_sig_loc -- print contextual info (#19055) - , text $ unpackHDS doc + , pprHsDocStrings $ map hsDocString doc ] handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m a diff --git a/hadrian/src/Rules/SourceDist.hs b/hadrian/src/Rules/SourceDist.hs index c98069f073..f37e26ade8 100644 --- a/hadrian/src/Rules/SourceDist.hs +++ b/hadrian/src/Rules/SourceDist.hs @@ -152,6 +152,7 @@ prepareTree dest = do , (Stage0, compiler, "GHC/Cmm/Lexer.x", "GHC/Cmm/Lexer.hs") , (Stage0, compiler, "GHC/Parser.y", "GHC/Parser.hs") , (Stage0, compiler, "GHC/Parser/Lexer.x", "GHC/Parser/Lexer.hs") + , (Stage0, compiler, "GHC/Parser/HaddockLex.x", "GHC/Parser/HaddockLex.hs") , (Stage0, hpcBin, "HpcParser.y", "HpcParser.hs") , (Stage0, genprimopcode, "Parser.y", "Parser.hs") , (Stage0, genprimopcode, "Lexer.x", "Lexer.hs") diff --git a/hadrian/src/Rules/ToolArgs.hs b/hadrian/src/Rules/ToolArgs.hs index 1ed15d8f05..eff690cd9b 100644 --- a/hadrian/src/Rules/ToolArgs.hs +++ b/hadrian/src/Rules/ToolArgs.hs @@ -70,6 +70,7 @@ allDeps = do need [ root -/- dir -/- "GHC" -/- "Settings" -/- "Config.hs" ] need [ root -/- dir -/- "GHC" -/- "Parser.hs" ] need [ root -/- dir -/- "GHC" -/- "Parser" -/- "Lexer.hs" ] + need [ root -/- dir -/- "GHC" -/- "Parser" -/- "HaddockLex.hs" ] need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Parser.hs" ] need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Lexer.hs" ] diff --git a/hadrian/src/Settings/Builders/Haddock.hs b/hadrian/src/Settings/Builders/Haddock.hs index 5aeba0c805..6dc4dbde68 100644 --- a/hadrian/src/Settings/Builders/Haddock.hs +++ b/hadrian/src/Settings/Builders/Haddock.hs @@ -50,7 +50,6 @@ haddockBuilderArgs = mconcat , arg $ "-B" ++ root -/- stageString Stage1 -/- "lib" , arg $ "--lib=" ++ root -/- stageString Stage1 -/- "lib" , arg $ "--odir=" ++ takeDirectory output - , arg "--no-tmp-comp-dir" , arg $ "--dump-interface=" ++ output , arg "--html" , arg "--hyperlinked-source" diff --git a/libraries/base/Data/Function.hs b/libraries/base/Data/Function.hs index 17cd5eef90..2947fd58d1 100644 --- a/libraries/base/Data/Function.hs +++ b/libraries/base/Data/Function.hs @@ -1,5 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} + -- Show the levity-polymorphic signature of '$' ----------------------------------------------------------------------------- -- | diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index 62c36cb0d5..b6ffd29da1 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -6,6 +6,7 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE Unsafe #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} ----------------------------------------------------------------------------- -- | diff --git a/libraries/ghc-boot/GHC/Utils/Encoding.hs b/libraries/ghc-boot/GHC/Utils/Encoding.hs index 5eb3779b3b..5714bef418 100644 --- a/libraries/ghc-boot/GHC/Utils/Encoding.hs +++ b/libraries/ghc-boot/GHC/Utils/Encoding.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-} {-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected. This module used to live in the `ghc` diff --git a/libraries/ghc-prim/GHC/Magic.hs b/libraries/ghc-prim/GHC/Magic.hs index b032056ed3..a8eb3b2f56 100644 --- a/libraries/ghc-prim/GHC/Magic.hs +++ b/libraries/ghc-prim/GHC/Magic.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} ----------------------------------------------------------------------------- -- | diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 4c6a3c6a17..843da4055c 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -4,6 +4,7 @@ TypeApplications, StandaloneKindSignatures, FlexibleInstances, UndecidableInstances #-} -- NegativeLiterals: see Note [Fixity of (->)] +{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Types diff --git a/rules/haddock.mk b/rules/haddock.mk index 4f084f86e3..b6d8e97051 100644 --- a/rules/haddock.mk +++ b/rules/haddock.mk @@ -66,7 +66,6 @@ endif "$$(TOP)/$$(INPLACE_BIN)/haddock" \ --verbosity=0 \ --odir="$1/$2/doc/html/$$($1_PACKAGE)" \ - --no-tmp-comp-dir \ --dump-interface=$$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_FILE) \ --html \ --hoogle \ @@ -83,12 +82,6 @@ endif $$(EXTRA_HADDOCK_OPTS) \ +RTS -t"$$(TOP)/testsuite/tests/perf/haddock/$$($1_PACKAGE).t" --machine-readable -# --no-tmp-comp-dir above is important: it saves a few minutes in a -# validate. This flag lets Haddock use the pre-compiled object files -# for the package rather than rebuilding the modules of the package in -# a temporary directory. Haddock needs to build the package when it -# uses the Template Haskell or Annotations extensions, for example. - # Make the haddocking depend on the library .a file, to ensure # that we wait until the library is fully built before we haddock it $$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_FILE) : $$($1_$2_$$(HADDOCK_WAY)_LIB) diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 056b797342..cdc300aa2f 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,4 +1,4 @@ -Found 281 Language.Haskell.Syntax module dependencies +Found 282 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -107,6 +107,7 @@ GHC.Hs GHC.Hs.Binds GHC.Hs.Decls GHC.Hs.Doc +GHC.Hs.DocString GHC.Hs.Expr GHC.Hs.Extension GHC.Hs.ImpExp diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index aa5af3c8c5..ddfc30e010 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,4 +1,4 @@ -Found 287 GHC.Parser module dependencies +Found 289 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -108,6 +108,7 @@ GHC.Hs GHC.Hs.Binds GHC.Hs.Decls GHC.Hs.Doc +GHC.Hs.DocString GHC.Hs.Expr GHC.Hs.Extension GHC.Hs.ImpExp @@ -133,6 +134,7 @@ GHC.Parser.CharClass GHC.Parser.Errors.Basic GHC.Parser.Errors.Ppr GHC.Parser.Errors.Types +GHC.Parser.HaddockLex GHC.Parser.Lexer GHC.Parser.PostProcess GHC.Parser.PostProcess.Haddock diff --git a/testsuite/tests/ghc-api/T11579.stdout b/testsuite/tests/ghc-api/T11579.stdout index 24f3bf52e5..1140ed9228 100644 --- a/testsuite/tests/ghc-api/T11579.stdout +++ b/testsuite/tests/ghc-api/T11579.stdout @@ -1 +1 @@ -HdkCommentNamed "bar" (HsDocString " some\n named chunk") +HdkCommentNamed "bar" (MultiLineDocString (HsDocStringNamed "bar") (L (RealSrcSpan SrcSpanOneLine "Foo.hs" 1 8 13 (Just (BufSpan {bufSpanStart = BufPos {bufPos = 7}, bufSpanEnd = BufPos {bufPos = 12}}))) (HsDocStringChunk " some") :| [L (RealSrcSpan SrcSpanOneLine "Foo.hs" 2 3 15 (Just (BufSpan {bufSpanStart = BufPos {bufPos = 15}, bufSpanEnd = BufPos {bufPos = 27}}))) (HsDocStringChunk " named chunk")])) diff --git a/testsuite/tests/ghci/scripts/ghci065.stdout b/testsuite/tests/ghci/scripts/ghci065.stdout index 39b990b04c..e4048832cc 100644 --- a/testsuite/tests/ghci/scripts/ghci065.stdout +++ b/testsuite/tests/ghci/scripts/ghci065.stdout @@ -1,32 +1,32 @@ Data1 :: * -- Type constructor defined at ghci065.hs:14:1 - This is the haddock comment of a data declaration for Data1. +-- | This is the haddock comment of a data declaration for Data1. Val2a :: Data2 -- Data constructor defined at ghci065.hs:16:14 - This is the haddock comment of a data value for Val2a +-- ^ This is the haddock comment of a data value for Val2a Val2b :: Data2 -- Data constructor defined at ghci065.hs:17:14 - This is the haddock comment of a data value for Val2b +-- ^ This is the haddock comment of a data value for Val2b Data3 :: * -- Type constructor defined at ghci065.hs:20:1 - This is the haddock comment of a data declaration for Data3. +-- | This is the haddock comment of a data declaration for Data3. Data4 :: Int -> Data4 -- Data constructor defined at ghci065.hs:25:3 - This is the haddock comment of a data constructor for Data4. +-- | This is the haddock comment of a data constructor for Data4. dupeField :: DupeFields2 -> Int -- Identifier defined at ghci065.hs:32:9 - This is the second haddock comment of a duplicate record field. +-- ^ This is the second haddock comment of a duplicate record field. dupeField :: DupeFields1 -> Int -- Identifier defined at ghci065.hs:28:9 - This is the first haddock comment of a duplicate record field. +-- ^ This is the first haddock comment of a duplicate record field. func1 :: Int -> Int -> Int -- Identifier defined at ghci065.hs:41:1 - This is the haddock comment of a function declaration for func1. +-- | This is the haddock comment of a function declaration for func1. <has no documentation> func3 :: Int -> Int -> Int -- Identifier defined at ghci065.hs:50:1 - This is the haddock comment of a function declaration for func3. - Here's multiple line comment for func3. +-- | This is the haddock comment of a function declaration for func3. +-- Here's multiple line comment for func3. PatSyn :: Int -- Pattern synonym defined at ghci065.hs:54:1 - This is the haddock comment of a pattern synonym +-- | This is the haddock comment of a pattern synonym TyCl :: k -> Constraint -- Class defined at ghci065.hs:57:1 - This is the haddock comment of a type class +-- | This is the haddock comment of a type class TyFam :: * -> * -- Type constructor defined at ghci065.hs:60:1 - This is the haddock comment of a type family +-- | This is the haddock comment of a type family diff --git a/testsuite/tests/ghci/scripts/ghci066.stdout b/testsuite/tests/ghci/scripts/ghci066.stdout index f56daddbdb..0f38f9c386 100644 --- a/testsuite/tests/ghci/scripts/ghci066.stdout +++ b/testsuite/tests/ghci/scripts/ghci066.stdout @@ -1,3 +1,3 @@ GHC.Prim.byteSwap# :: GHC.Prim.Word# -> GHC.Prim.Word# -- Identifier defined in ‘GHC.Prim’ -Swap bytes in a word. +-- |Swap bytes in a word. diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr index d230d58eaa..22dad49b1a 100644 --- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr +++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr @@ -17,76 +17,90 @@ visible a = a [3 of 3] Compiling Test ( Test.hs, Test.o ) ==================== Parser ==================== -" - Module : Test - Copyright : (c) Simon Marlow 2002 - License : BSD-style - - Maintainer : libraries@haskell.org - Stability : provisional - Portability : portable - - This module illustrates & tests most of the features of Haddock. - Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. -" +-- | +-- Module : Test +-- Copyright : (c) Simon Marlow 2002 +-- License : BSD-style +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- This module illustrates & tests most of the features of Haddock. +-- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. +-- module Test ( <IEGroup: 1>, <IEGroup: 2>, T(..), T2, T3(..), T4(..), T5(..), T6(..), N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..), <IEGroup: 2>, R(..), R1(..), - " test that we can export record selectors on their own:", p, q, u, + test that we can export record selectors on their own:, p, q, u, <IEGroup: 1>, C(a, b), D(..), E, F(..), - " Test that we can export a class method on its own:", a, + Test that we can export a class method on its own:, a, <IEGroup: 1>, f, g, <IEGroup: 1>, <IEDocNamed: aux1>, <IEDocNamed: aux2>, <IEDocNamed: aux3>, <IEDocNamed: aux4>, <IEDocNamed: aux5>, <IEDocNamed: aux6>, <IEDocNamed: aux7>, <IEDocNamed: aux8>, <IEDocNamed: aux9>, <IEDocNamed: aux10>, <IEDocNamed: aux11>, <IEDocNamed: aux12>, - " This is some inline documentation in the export list + This is some inline documentation in the export list > a code block using bird-tracks > each line must begin with > (which isn't significant unless it - > is at the beginning of the line).", + > is at the beginning of the line)., <IEGroup: 1>, module Hidden, <IEGroup: 1>, module Visible, - " nested-style doc comments ", <IEGroup: 1>, Ex(..), <IEGroup: 1>, - k, l, m, o, <IEGroup: 1>, <IEGroup: 2>, - " + nested-style doc comments , <IEGroup: 1>, Ex(..), <IEGroup: 1>, k, + l, m, o, <IEGroup: 1>, <IEGroup: 2>, + > a literal line $ a non /literal/ line $ -", f' +, f' ) where import Hidden import Visible <document comment> data T a b - = " This comment describes the 'A' constructor" + = -- | This comment describes the 'A' constructor A Int (Maybe Float) | - " This comment describes the 'B' constructor" + -- | This comment describes the 'B' constructor B (T a b, T Int Float) <document comment> data T2 a b = T2 a b <document comment> data T3 a b = A1 a | B1 b data T4 a b = A2 a | B2 b -data T5 a b = " documents 'A3'" A3 a | " documents 'B3'" B3 b +data T5 a b + = -- | documents 'A3' + A3 a | + -- | documents 'B3' + B3 b <document comment> data T6 - = " This is the doc for 'A4'" A4 | - " This is the doc for 'B4'" B4 | - " This is the doc for 'C4'" C4 + = -- | This is the doc for 'A4' + A4 | + -- | This is the doc for 'B4' + B4 | + -- | This is the doc for 'C4' + C4 <document comment> newtype N1 a = N1 a <document comment> newtype N2 a b = N2 {n :: a b} <document comment> -newtype N3 a b = N3 {n3 :: a b " this is the 'n3' field"} +newtype N3 a b + = N3 {-- | this is the 'n3' field + n3 :: a b} <document comment> newtype N4 a b = N4 a newtype N5 a b - = N5 {n5 :: a b " no docs on the datatype or the constructor"} -newtype N6 a b = " docs on the constructor only" N6 {n6 :: a b} -<document comment> -newtype N7 a b = " The 'N7' constructor" N7 {n7 :: a b} + = N5 {-- | no docs on the datatype or the constructor + n5 :: a b} +newtype N6 a b + = -- | docs on the constructor only + N6 {n6 :: a b} +<document comment> +newtype N7 a b + = -- | The 'N7' constructor + N7 {n7 :: a b} class (D a) => C a where a :: IO a b :: [a] @@ -109,20 +123,26 @@ class F a where ff :: a <document comment> data R - = " This is the 'C1' record constructor, with the following fields:" - C1 {p :: Int " This comment applies to the 'p' field", - q :: forall a. a -> a " This comment applies to the 'q' field", - r, s :: Int " This comment applies to both 'r' and 's'"} | - " This is the 'C2' record constructor, also with some fields:" + = -- | This is the 'C1' record constructor, with the following fields: + C1 {-- | This comment applies to the 'p' field + p :: Int, + -- | This comment applies to the 'q' field + q :: forall a. a -> a, + -- | This comment applies to both 'r' and 's' + r, s :: Int} | + -- | This is the 'C2' record constructor, also with some fields: C2 {t :: T1 -> (T2 Int Int) -> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), u, v :: Int} <document comment> data R1 - = " This is the 'C3' record constructor" - C3 {s1 :: Int " The 's1' record selector", - s2 :: Int " The 's2' record selector", - s3 :: Int " The 's3' record selector"} + = -- | This is the 'C3' record constructor + C3 {-- | The 's1' record selector + s1 :: Int, + -- | The 's2' record selector + s2 :: Int, + -- | The 's3' record selector + s3 :: Int} <document comment> <document comment> <document comment> @@ -153,27 +173,44 @@ data Ex a Ex4 (forall a. a -> a) <document comment> k :: - T () () " This argument has type 'T'" - -> (T2 Int Int) " This argument has type 'T2 Int Int'" - -> (T3 Bool Bool - -> T4 Float Float) " This argument has type @T3 Bool Bool -> T4 Float Float@" - -> T5 () () " This argument has a very long description that should - hopefully cause some wrapping to happen when it is finally - rendered by Haddock in the generated HTML page." - -> IO () " This is the result type" -l :: (Int, Int, Float) " takes a triple" -> Int " returns an 'Int'" + -- | This argument has type 'T' + T () () + -> -- | This argument has type 'T2 Int Int' + (T2 Int Int) + -> -- | This argument has type @T3 Bool Bool -> T4 Float Float@ + (T3 Bool Bool -> T4 Float Float) + -> -- | This argument has a very long description that should +-- hopefully cause some wrapping to happen when it is finally +-- rendered by Haddock in the generated HTML page. + T5 () () + -> -- | This is the result type + IO () +l :: + -- | takes a triple + (Int, Int, Float) + -> -- | returns an 'Int' + Int <document comment> m :: R - -> N1 () " one of the arguments" -> IO Int " and the return value" + -> -- | one of the arguments + N1 () + -> -- | and the return value + IO Int <document comment> newn :: - R " one of the arguments, an 'R'" - -> N1 () " one of the arguments" -> IO Int + -- | one of the arguments, an 'R' + R + -> -- | one of the arguments + N1 () + -> IO Int newn = undefined <document comment> foreign import ccall unsafe "header.h" o - :: Float " The input float" -> IO Float " The output float" + :: -- | The input float + Float + -> -- | The output float + IO Float <document comment> newp :: Int newp = undefined diff --git a/testsuite/tests/haddock/perf/Fold.hs b/testsuite/tests/haddock/perf/Fold.hs new file mode 100644 index 0000000000..4e0be9cbd0 --- /dev/null +++ b/testsuite/tests/haddock/perf/Fold.hs @@ -0,0 +1,5184 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wno-orphans #-} +---------------------------------------------------------------------------- +-- | +-- Module : Control.Lens.Fold +-- Copyright : (C) 2012-16 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett <ekmett@gmail.com> +-- Stability : provisional +-- Portability : Rank2Types +-- +-- A @'Fold' s a@ is a generalization of something 'Foldable'. It allows +-- you to extract multiple results from a container. A 'Foldable' container +-- can be characterized by the behavior of +-- @'Data.Foldable.foldMap' :: ('Foldable' t, 'Monoid' m) => (a -> m) -> t a -> m@. +-- Since we want to be able to work with monomorphic containers, we could +-- generalize this signature to @forall m. 'Monoid' m => (a -> m) -> s -> m@, +-- and then decorate it with 'Const' to obtain +-- +-- @type 'Fold' s a = forall m. 'Monoid' m => 'Getting' m s a@ +-- +-- Every 'Getter' is a valid 'Fold' that simply doesn't use the 'Monoid' +-- it is passed. +-- +-- In practice the type we use is slightly more complicated to allow for +-- better error messages and for it to be transformed by certain +-- 'Applicative' transformers. +-- +-- Everything you can do with a 'Foldable' container, you can with with a 'Fold' and there are +-- combinators that generalize the usual 'Foldable' operations here. +---------------------------------------------------------------------------- +module Control.Lens.Fold + ( + -- * Folds + Fold + , IndexedFold + + -- * Getting Started + , (^..) + , (^?) + , (^?!) + , pre, ipre + , preview, previews, ipreview, ipreviews + , preuse, preuses, ipreuse, ipreuses + + , has, hasn't + + -- ** Building Folds + , folding, ifolding + , foldring, ifoldring + , folded + , folded64 + , unfolded + , iterated + , filtered + , filteredBy + , backwards + , repeated + , replicated + , cycled + , takingWhile + , droppingWhile + , worded, lined + + -- ** Folding + , foldMapOf, foldOf + , foldrOf, foldlOf + , toListOf, toNonEmptyOf + , anyOf, allOf, noneOf + , andOf, orOf + , productOf, sumOf + , traverseOf_, forOf_, sequenceAOf_ + , traverse1Of_, for1Of_, sequence1Of_ + , mapMOf_, forMOf_, sequenceOf_ + , asumOf, msumOf + , concatMapOf, concatOf + , elemOf, notElemOf + , lengthOf + , nullOf, notNullOf + , firstOf, first1Of, lastOf, last1Of + , maximumOf, maximum1Of, minimumOf, minimum1Of + , maximumByOf, minimumByOf + , findOf + , findMOf + , foldrOf', foldlOf' + , foldr1Of, foldl1Of + , foldr1Of', foldl1Of' + , foldrMOf, foldlMOf + , lookupOf + + -- * Indexed Folds + , (^@..) + , (^@?) + , (^@?!) + + -- ** Indexed Folding + , ifoldMapOf + , ifoldrOf + , ifoldlOf + , ianyOf + , iallOf + , inoneOf + , itraverseOf_ + , iforOf_ + , imapMOf_ + , iforMOf_ + , iconcatMapOf + , ifindOf + , ifindMOf + , ifoldrOf' + , ifoldlOf' + , ifoldrMOf + , ifoldlMOf + , itoListOf + , elemIndexOf + , elemIndicesOf + , findIndexOf + , findIndicesOf + + -- ** Building Indexed Folds + , ifiltered + , itakingWhile + , idroppingWhile + + -- * Internal types + , Leftmost + , Rightmost + , Traversed + , Sequenced + + ) where + +import Prelude +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Control.Monad as Monad +import Control.Monad.Reader +import qualified Control.Monad.Reader as Reader +import Data.Functor +import Control.Monad.State +import Data.Int (Int64) +import Data.List (intercalate) +import Data.Maybe (fromMaybe, Maybe(..)) +import Data.Monoid (First (..), All (..), Any (..), Endo (..), Dual(..), Monoid(..)) +import qualified Data.Monoid as Monoid +import Data.Ord (Down(..)) +import Data.Functor.Compose +import Data.Functor.Contravariant +import Control.Applicative +import GHC.Stack +import Control.Applicative.Backwards +import Data.Kind +import Data.Functor.Identity +import Data.Bifunctor +import Control.Arrow (Arrow, ArrowApply(..), ArrowChoice(..), ArrowLoop(..), (&&&), (***)) +import qualified Control.Arrow as Arrow +import qualified Control.Category as C +import Control.Monad.Writer +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Except +import Data.Tree +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Control.Monad.State as State +import Control.Monad.Writer +import Data.Coerce +import qualified GHC.Generics as Generics +import GHC.Generics (K1(..), U1(..), Par1(..), (:.:)(..), Rec1, M1, (:*:)(..)) +import Control.Monad.Trans.Cont +import qualified Data.Semigroup as Semi +import qualified Data.Semigroup as Semigroup +import Data.Complex +import Control.Monad.Trans.Identity +import qualified Data.Functor.Product as Functor +import Data.Proxy +import Data.Typeable +import Data.Ix +import Data.Foldable (traverse_) + +infixr 9 #. +infixl 8 .# + +{- | + +There are two ways to define a comonad: + +I. Provide definitions for 'extract' and 'extend' +satisfying these laws: + +@ +'extend' 'extract' = 'id' +'extract' . 'extend' f = f +'extend' f . 'extend' g = 'extend' (f . 'extend' g) +@ + +In this case, you may simply set 'fmap' = 'liftW'. + +These laws are directly analogous to the laws for monads +and perhaps can be made clearer by viewing them as laws stating +that Cokleisli composition must be associative, and has extract for +a unit: + +@ +f '=>=' 'extract' = f +'extract' '=>=' f = f +(f '=>=' g) '=>=' h = f '=>=' (g '=>=' h) +@ + +II. Alternately, you may choose to provide definitions for 'fmap', +'extract', and 'duplicate' satisfying these laws: + +@ +'extract' . 'duplicate' = 'id' +'fmap' 'extract' . 'duplicate' = 'id' +'duplicate' . 'duplicate' = 'fmap' 'duplicate' . 'duplicate' +@ + +In this case you may not rely on the ability to define 'fmap' in +terms of 'liftW'. + +You may of course, choose to define both 'duplicate' /and/ 'extend'. +In that case you must also satisfy these laws: + +@ +'extend' f = 'fmap' f . 'duplicate' +'duplicate' = 'extend' id +'fmap' f = 'extend' (f . 'extract') +@ + +These are the default definitions of 'extend' and 'duplicate' and +the definition of 'liftW' respectively. + +-} + +class Functor w => Comonad w where + -- | + -- @ + -- 'extract' . 'fmap' f = f . 'extract' + -- @ + extract :: w a -> a + + -- | + -- @ + -- 'duplicate' = 'extend' 'id' + -- 'fmap' ('fmap' f) . 'duplicate' = 'duplicate' . 'fmap' f + -- @ + duplicate :: w a -> w (w a) + duplicate = extend id + + -- | + -- @ + -- 'extend' f = 'fmap' f . 'duplicate' + -- @ + extend :: (w a -> b) -> w a -> w b + extend f = fmap f . duplicate + +-- | A 'Profunctor' @p@ is a 'Sieve' __on__ @f@ if it is a subprofunctor of @'Star' f@. +-- +-- That is to say it is a subset of @Hom(-,f=)@ closed under 'lmap' and 'rmap'. +-- +-- Alternately, you can view it as a sieve __in__ the comma category @Hask/f@. +class (Profunctor p, Functor f) => Sieve p f | p -> f where + sieve :: p a b -> a -> f b + +instance Sieve (->) Identity where + sieve f = Identity . f + {-# INLINE sieve #-} + +instance (Monad m, Functor m) => Sieve (Arrow.Kleisli m) m where + sieve = Arrow.runKleisli + {-# INLINE sieve #-} + +-- | A 'Profunctor' @p@ is a 'Cosieve' __on__ @f@ if it is a subprofunctor of @'Costar' f@. +-- +-- That is to say it is a subset of @Hom(f-,=)@ closed under 'lmap' and 'rmap'. +-- +-- Alternately, you can view it as a cosieve __in__ the comma category @f/Hask@. +class (Profunctor p, Functor f) => Cosieve p f | p -> f where + cosieve :: p a b -> f a -> b + +instance Cosieve (->) Identity where + cosieve f (Identity d) = f d + {-# INLINE cosieve #-} + +instance Cosieve Tagged Proxy where + cosieve (Tagged a) _ = a + {-# INLINE cosieve #-} + +-- * Representable Profunctors + +-- | A 'Profunctor' @p@ is 'Representable' if there exists a 'Functor' @f@ such that +-- @p d c@ is isomorphic to @d -> f c@. +class (Sieve p (Rep p), Strong p) => Representable p where + type Rep p :: * -> * + -- | Laws: + -- + -- @ + -- 'tabulate' '.' 'sieve' ≡ 'id' + -- 'sieve' '.' 'tabulate' ≡ 'id' + -- @ + tabulate :: (d -> Rep p c) -> p d c + +-- | Default definition for 'first'' given that p is 'Representable'. +firstRep :: Representable p => p a b -> p (a, c) (b, c) +firstRep p = tabulate $ \(a,c) -> (\b -> (b, c)) <$> sieve p a + +-- | Default definition for 'second'' given that p is 'Representable'. +secondRep :: Representable p => p a b -> p (c, a) (c, b) +secondRep p = tabulate $ \(c,a) -> (,) c <$> sieve p a + +instance Representable (->) where + type Rep (->) = Identity + tabulate f = runIdentity . f + {-# INLINE tabulate #-} + +instance (Monad m, Functor m) => Representable (Arrow.Kleisli m) where + type Rep (Arrow.Kleisli m) = m + tabulate = Arrow.Kleisli + {-# INLINE tabulate #-} + +{- TODO: coproducts and products +instance (Representable p, Representable q) => Representable (Bifunctor.Product p q) + type Rep (Bifunctor.Product p q) = Functor.Product p q + +instance (Corepresentable p, Corepresentable q) => Corepresentable (Bifunctor.Product p q) where + type Rep (Bifunctor.Product p q) = Functor.Sum p q +-} + +---------------------------------------------------------------------------- +-- * Pastro +---------------------------------------------------------------------------- + +-- | Pastro -| Tambara +-- +-- @ +-- Pastro p ~ exists z. Costar ((,)z) `Procompose` p `Procompose` Star ((,)z) +-- @ +-- +-- 'Pastro' freely makes any 'Profunctor' 'Strong'. +data Pastro p a b where + Pastro :: ((y, z) -> b) -> p x y -> (a -> (x, z)) -> Pastro p a b + +instance Functor (Pastro p a) where + fmap f (Pastro l m r) = Pastro (f . l) m r + +instance Profunctor (Pastro p) where + dimap f g (Pastro l m r) = Pastro (g . l) m (r . f) + lmap f (Pastro l m r) = Pastro l m (r . f) + rmap g (Pastro l m r) = Pastro (g . l) m r + w #. Pastro l m r = Pastro (w #. l) m r + Pastro l m r .# w = Pastro l m (r .# w) + +-------------------------------------------------------------------------------- +-- * Costrength for (,) +-------------------------------------------------------------------------------- + +-- | Analogous to 'ArrowLoop', 'loop' = 'unfirst' +class Profunctor p => Costrong p where + -- | Laws: + -- + -- @ + -- 'unfirst' ≡ 'unsecond' '.' 'dimap' 'swap' 'swap' + -- 'lmap' (,()) ≡ 'unfirst' '.' 'rmap' (,()) + -- 'unfirst' '.' 'lmap' ('second' f) ≡ 'unfirst' '.' 'rmap' ('second' f) + -- 'unfirst' '.' 'unfirst' = 'unfirst' '.' 'dimap' assoc unassoc where + -- assoc ((a,b),c) = (a,(b,c)) + -- unassoc (a,(b,c)) = ((a,b),c) + -- @ + unfirst :: p (a, d) (b, d) -> p a b + unfirst = unsecond . dimap swap swap + + -- | Laws: + -- + -- @ + -- 'unsecond' ≡ 'unfirst' '.' 'dimap' 'swap' 'swap' + -- 'lmap' ((),) ≡ 'unsecond' '.' 'rmap' ((),) + -- 'unsecond' '.' 'lmap' ('first' f) ≡ 'unsecond' '.' 'rmap' ('first' f) + -- 'unsecond' '.' 'unsecond' = 'unsecond' '.' 'dimap' unassoc assoc where + -- assoc ((a,b),c) = (a,(b,c)) + -- unassoc (a,(b,c)) = ((a,b),c) + -- @ + unsecond :: p (d, a) (d, b) -> p a b + unsecond = unfirst . dimap swap swap + + {-# MINIMAL unfirst | unsecond #-} + +instance Costrong (->) where + unfirst f a = b where (b, d) = f (a, d) + unsecond f a = b where (d, b) = f (d, a) + +instance Costrong Tagged where + unfirst (Tagged bd) = Tagged (fst bd) + unsecond (Tagged db) = Tagged (snd db) + +instance MonadFix m => Costrong (Arrow.Kleisli m) where + unfirst (Arrow.Kleisli f) = Arrow.Kleisli (liftM fst . mfix . f') + where f' x y = f (x, snd y) + +-- | 'tabulate' and 'sieve' form two halves of an isomorphism. +-- +-- This can be used with the combinators from the @lens@ package. +-- +-- @'tabulated' :: 'Representable' p => 'Iso'' (d -> 'Rep' p c) (p d c)@ +tabulated :: (Representable p, Representable q) => Iso (d -> Rep p c) (d' -> Rep q c') (p d c) (q d' c') +tabulated = dimap tabulate (fmap sieve) +{-# INLINE tabulated #-} + +-- * Corepresentable Profunctors + +-- | A 'Profunctor' @p@ is 'Corepresentable' if there exists a 'Functor' @f@ such that +-- @p d c@ is isomorphic to @f d -> c@. +class (Cosieve p (Corep p), Costrong p) => Corepresentable p where + type Corep p :: * -> * + -- | Laws: + -- + -- @ + -- 'cotabulate' '.' 'cosieve' ≡ 'id' + -- 'cosieve' '.' 'cotabulate' ≡ 'id' + -- @ + cotabulate :: (Corep p d -> c) -> p d c + +-- | Default definition for 'unfirst' given that @p@ is 'Corepresentable'. +unfirstCorep :: Corepresentable p => p (a, d) (b, d) -> p a b +unfirstCorep p = cotabulate f + where f fa = b where (b, d) = cosieve p ((\a -> (a, d)) <$> fa) + +-- | Default definition for 'unsecond' given that @p@ is 'Corepresentable'. +unsecondCorep :: Corepresentable p => p (d, a) (d, b) -> p a b +unsecondCorep p = cotabulate f + where f fa = b where (d, b) = cosieve p ((,) d <$> fa) + +-- | Default definition for 'closed' given that @p@ is 'Corepresentable' +closedCorep :: Corepresentable p => p a b -> p (x -> a) (x -> b) +closedCorep p = cotabulate $ \fs x -> cosieve p (fmap ($ x) fs) + +instance Corepresentable (->) where + type Corep (->) = Identity + cotabulate f = f . Identity + {-# INLINE cotabulate #-} + +instance Corepresentable Tagged where + type Corep Tagged = Proxy + cotabulate f = Tagged (f Proxy) + {-# INLINE cotabulate #-} + +-- | 'cotabulate' and 'cosieve' form two halves of an isomorphism. +-- +-- This can be used with the combinators from the @lens@ package. +-- +-- @'cotabulated' :: 'Corep' f p => 'Iso'' (f d -> c) (p d c)@ +cotabulated :: (Corepresentable p, Corepresentable q) => Iso (Corep p d -> c) (Corep q d' -> c') (p d c) (q d' c') +cotabulated = dimap cotabulate (fmap cosieve) +{-# INLINE cotabulated #-} + +-------------------------------------------------------------------------------- +-- * Prep +-------------------------------------------------------------------------------- + +-- | @'Prep' -| 'Star' :: [Hask, Hask] -> Prof@ +-- +-- This gives rise to a monad in @Prof@, @('Star'.'Prep')@, and +-- a comonad in @[Hask,Hask]@ @('Prep'.'Star')@ +-- +-- 'Prep' has a polymorphic kind since @5.6@. + +-- Prep :: (Type -> k -> Type) -> (k -> Type) +data Prep p a where + Prep :: x -> p x a -> Prep p a + +instance Profunctor p => Functor (Prep p) where + fmap f (Prep x p) = Prep x (rmap f p) + +instance (Applicative (Rep p), Representable p) => Applicative (Prep p) where + pure a = Prep () $ tabulate $ const $ pure a + Prep xf pf <*> Prep xa pa = Prep (xf,xa) (tabulate go) where + go (xf',xa') = sieve pf xf' <*> sieve pa xa' + +instance (Monad (Rep p), Representable p) => Monad (Prep p) where + return a = Prep () $ tabulate $ const $ return a + Prep xa pa >>= f = Prep xa $ tabulate $ sieve pa >=> \a -> case f a of + Prep xb pb -> sieve pb xb + +-------------------------------------------------------------------------------- +-- * Coprep +-------------------------------------------------------------------------------- + +-- | 'Prep' has a polymorphic kind since @5.6@. + +-- Coprep :: (k -> Type -> Type) -> (k -> Type) +newtype Coprep p a = Coprep { runCoprep :: forall r. p a r -> r } + +instance Profunctor p => Functor (Coprep p) where + fmap f (Coprep g) = Coprep (g . lmap f) + + +------------------------------------------------------------------------------ +-- Strong +------------------------------------------------------------------------------ + +-- | Generalizing 'Star' of a strong 'Functor' +-- +-- /Note:/ Every 'Functor' in Haskell is strong with respect to @(,)@. +-- +-- This describes profunctor strength with respect to the product structure +-- of Hask. +-- +-- <http://www.riec.tohoku.ac.jp/~asada/papers/arrStrMnd.pdf> +-- +class Profunctor p => Strong p where + -- | Laws: + -- + -- @ + -- 'first'' ≡ 'dimap' 'swap' 'swap' '.' 'second'' + -- 'lmap' 'fst' ≡ 'rmap' 'fst' '.' 'first'' + -- 'lmap' ('second'' f) '.' 'first'' ≡ 'rmap' ('second'' f) '.' 'first'' + -- 'first'' '.' 'first'' ≡ 'dimap' assoc unassoc '.' 'first'' where + -- assoc ((a,b),c) = (a,(b,c)) + -- unassoc (a,(b,c)) = ((a,b),c) + -- @ + first' :: p a b -> p (a, c) (b, c) + first' = dimap swap swap . second' + + -- | Laws: + -- + -- @ + -- 'second'' ≡ 'dimap' 'swap' 'swap' '.' 'first'' + -- 'lmap' 'snd' ≡ 'rmap' 'snd' '.' 'second'' + -- 'lmap' ('first'' f) '.' 'second'' ≡ 'rmap' ('first'' f) '.' 'second'' + -- 'second'' '.' 'second'' ≡ 'dimap' unassoc assoc '.' 'second'' where + -- assoc ((a,b),c) = (a,(b,c)) + -- unassoc (a,(b,c)) = ((a,b),c) + -- @ + second' :: p a b -> p (c, a) (c, b) + second' = dimap swap swap . first' + + {-# MINIMAL first' | second' #-} + +uncurry' :: Strong p => p a (b -> c) -> p (a, b) c +uncurry' = rmap (\(f,x) -> f x) . first' +{-# INLINE uncurry' #-} + +strong :: Strong p => (a -> b -> c) -> p a b -> p a c +strong f x = dimap (\a -> (a, a)) (\(b, a) -> f a b) (first' x) + +instance Strong (->) where + first' ab ~(a, c) = (ab a, c) + {-# INLINE first' #-} + second' ab ~(c, a) = (c, ab a) + {-# INLINE second' #-} + +instance Monad m => Strong (Arrow.Kleisli m) where + first' (Arrow.Kleisli f) = Arrow.Kleisli $ \ ~(a, c) -> do + b <- f a + return (b, c) + {-# INLINE first' #-} + second' (Arrow.Kleisli f) = Arrow.Kleisli $ \ ~(c, a) -> do + b <- f a + return (c, b) + {-# INLINE second' #-} + +-- | A @'Tagged' s b@ value is a value @b@ with an attached phantom type @s@. +-- This can be used in place of the more traditional but less safe idiom of +-- passing in an undefined value with the type, because unlike an @(s -> b)@, +-- a @'Tagged' s b@ can't try to use the argument @s@ as a real value. +-- +-- Moreover, you don't have to rely on the compiler to inline away the extra +-- argument, because the newtype is \"free\" +-- +-- 'Tagged' has kind @k -> * -> *@ if the compiler supports @PolyKinds@, therefore +-- there is an extra @k@ showing in the instance haddocks that may cause confusion. +newtype Tagged s b = Tagged { unTagged :: b } deriving + ( Eq, Ord, Ix, Bounded + , Generics.Generic + , Generics.Generic1 + , Typeable + ) + +----------------------------------------------------------------------------- +-- Settable +----------------------------------------------------------------------------- + +-- | Anything 'Settable' must be isomorphic to the 'Identity' 'Functor'. +class (Applicative f, Distributive f, Traversable f) => Settable f where + untainted :: f a -> a + + untaintedDot :: Profunctor p => p a (f b) -> p a b + untaintedDot g = g `seq` rmap untainted g + {-# INLINE untaintedDot #-} + + taintedDot :: Profunctor p => p a b -> p a (f b) + taintedDot g = g `seq` rmap pure g + {-# INLINE taintedDot #-} + +-- | So you can pass our 'Control.Lens.Setter.Setter' into combinators from other lens libraries. +instance Settable Identity where + untainted = runIdentity + {-# INLINE untainted #-} + untaintedDot = (runIdentity #.) + {-# INLINE untaintedDot #-} + taintedDot = (Identity #.) + {-# INLINE taintedDot #-} + +-- | 'Control.Lens.Fold.backwards' +instance Settable f => Settable (Backwards f) where + untainted = untaintedDot forwards + {-# INLINE untainted #-} + +instance (Settable f, Settable g) => Settable (Compose f g) where + untainted = untaintedDot (untaintedDot getCompose) + {-# INLINE untainted #-} + + +-- $setup +-- >>> :set -XNoOverloadedStrings +-- >>> import Control.Lens +-- >>> import Control.Lens.Extras (is) +-- >>> import Data.Function +-- >>> import Data.List.Lens +-- >>> import Data.List.NonEmpty (NonEmpty (..)) +-- >>> import Debug.SimpleReflect.Expr +-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g) +-- >>> import Control.DeepSeq (NFData (..), force) +-- >>> import Control.Exception (evaluate) +-- >>> import Data.Maybe (fromMaybe) +-- >>> import Data.Monoid (Sum (..)) +-- >>> import System.Timeout (timeout) +-- >>> import qualified Data.Map as Map +-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f +-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g +-- >>> let timingOut :: NFData a => a -> IO a; timingOut = fmap (fromMaybe (error "timeout")) . timeout (5*10^6) . evaluate . force + +infixl 8 ^.., ^?, ^?!, ^@.., ^@?, ^@?! + +infixl 8 ^., ^@. + +infixl 4 <.>, <., .> + +class Distributive f + +-- | The generalization of 'Costar' of 'Functor' that is strong with respect +-- to 'Either'. +-- +-- Note: This is also a notion of strength, except with regards to another monoidal +-- structure that we can choose to equip Hask with: the cocartesian coproduct. +class Profunctor p => Choice p where + -- | Laws: + -- + -- @ + -- 'left'' ≡ 'dimap' swapE swapE '.' 'right'' where + -- swapE :: 'Either' a b -> 'Either' b a + -- swapE = 'either' 'Right' 'Left' + -- 'rmap' 'Left' ≡ 'lmap' 'Left' '.' 'left'' + -- 'lmap' ('right' f) '.' 'left'' ≡ 'rmap' ('right' f) '.' 'left'' + -- 'left'' '.' 'left'' ≡ 'dimap' assocE unassocE '.' 'left'' where + -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) + -- assocE ('Left' ('Left' a)) = 'Left' a + -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) + -- assocE ('Right' c) = 'Right' ('Right' c) + -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c + -- unassocE ('Left' a) = 'Left' ('Left' a) + -- unassocE ('Right' ('Left' b)) = 'Left' ('Right' b) + -- unassocE ('Right' ('Right' c)) = 'Right' c + -- @ + left' :: p a b -> p (Either a c) (Either b c) + left' = dimap (either Right Left) (either Right Left) . right' + + -- | Laws: + -- + -- @ + -- 'right'' ≡ 'dimap' swapE swapE '.' 'left'' where + -- swapE :: 'Either' a b -> 'Either' b a + -- swapE = 'either' 'Right' 'Left' + -- 'rmap' 'Right' ≡ 'lmap' 'Right' '.' 'right'' + -- 'lmap' ('left' f) '.' 'right'' ≡ 'rmap' ('left' f) '.' 'right'' + -- 'right'' '.' 'right'' ≡ 'dimap' unassocE assocE '.' 'right'' where + -- assocE :: 'Either' ('Either' a b) c -> 'Either' a ('Either' b c) + -- assocE ('Left' ('Left' a)) = 'Left' a + -- assocE ('Left' ('Right' b)) = 'Right' ('Left' b) + -- assocE ('Right' c) = 'Right' ('Right' c) + -- unassocE :: 'Either' a ('Either' b c) -> 'Either' ('Either' a b) c + -- unassocE ('Left' a) = 'Left' ('Left' a) + -- unassocE ('Right' ('Left' b)) = 'Left' ('Right' b) + -- unassocE ('Right' ('Right' c)) = 'Right' c + -- @ + right' :: p a b -> p (Either c a) (Either c b) + right' = dimap (either Right Left) (either Right Left) . left' + + {-# MINIMAL left' | right' #-} + +instance Choice (->) where + left' ab (Left a) = Left (ab a) + left' _ (Right c) = Right c + {-# INLINE left' #-} + right' = fmap + {-# INLINE right' #-} + +instance Profunctor (->) where + dimap ab cd bc = cd . bc . ab + {-# INLINE dimap #-} + lmap = flip (.) + {-# INLINE lmap #-} + rmap = (.) + {-# INLINE rmap #-} + (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b + (.#) pbc _ = coerce pbc + {-# INLINE (#.) #-} + {-# INLINE (.#) #-} + +instance Comonad Identity +instance Comonad ((,) i) +instance Applicative (Tagged a) +instance Functor (Tagged a) +instance Profunctor Tagged +instance Profunctor (Arrow.Kleisli m) +instance Distributive (Compose f g) +instance Distributive (Backwards f) +instance Distributive Identity + +instance Monad m => Choice (Arrow.Kleisli m) where + left' = left + {-# INLINE left' #-} + right' = right + {-# INLINE right' #-} + +instance Choice Tagged where + left' (Tagged b) = Tagged (Left b) + {-# INLINE left' #-} + right' (Tagged b) = Tagged (Right b) + {-# INLINE right' #-} + +-- | A strong lax semi-monoidal endofunctor. +-- This is equivalent to an 'Applicative' without 'pure'. +-- +-- Laws: +-- +-- @ +-- ('.') '<$>' u '<.>' v '<.>' w = u '<.>' (v '<.>' w) +-- x '<.>' (f '<$>' y) = ('.' f) '<$>' x '<.>' y +-- f '<$>' (x '<.>' y) = (f '.') '<$>' x '<.>' y +-- @ +-- +-- The laws imply that `.>` and `<.` really ignore their +-- left and right results, respectively, and really +-- return their right and left results, respectively. +-- Specifically, +-- +-- @ +-- (mf '<$>' m) '.>' (nf '<$>' n) = nf '<$>' (m '.>' n) +-- (mf '<$>' m) '<.' (nf '<$>' n) = mf '<$>' (m '<.' n) +-- @ +class Functor f => Apply f where + (<.>) :: f (a -> b) -> f a -> f b + (<.>) = liftF2 id + + -- | @ a '.>' b = 'const' 'id' '<$>' a '<.>' b @ + (.>) :: f a -> f b -> f b + a .> b = const id <$> a <.> b + + -- | @ a '<.' b = 'const' '<$>' a '<.>' b @ + (<.) :: f a -> f b -> f a + a <. b = const <$> a <.> b + + -- | Lift a binary function into a comonad with zipping + liftF2 :: (a -> b -> c) -> f a -> f b -> f c + liftF2 f a b = f <$> a <.> b + {-# INLINE liftF2 #-} + +instance Apply (Tagged a) where + (<.>) = (<*>) + (<.) = (<*) + (.>) = (*>) + +instance Apply Proxy where + (<.>) = (<*>) + (<.) = (<*) + (.>) = (*>) + +instance Apply f => Apply (Backwards f) where + Backwards f <.> Backwards a = Backwards (flip id <$> a <.> f) + +instance (Apply f, Apply g) => Apply (Compose f g) where + Compose f <.> Compose x = Compose ((<.>) <$> f <.> x) + +instance (Apply f, Apply g) => Apply (Functor.Product f g) where + Functor.Pair f g <.> Functor.Pair x y = Functor.Pair (f <.> x) (g <.> y) + +-- | A @'(,)' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply' +instance Semigroup m => Apply ((,)m) where + (m, f) <.> (n, a) = (m <> n, f a) + (m, a) <. (n, _) = (m <> n, a) + (m, _) .> (n, b) = (m <> n, b) + +instance Apply NonEmpty where + (<.>) = ap + +instance Apply (Either a) where + Left a <.> _ = Left a + Right _ <.> Left a = Left a + Right f <.> Right b = Right (f b) + + Left a <. _ = Left a + Right _ <. Left a = Left a + Right a <. Right _ = Right a + + Left a .> _ = Left a + Right _ .> Left a = Left a + Right _ .> Right b = Right b + +-- | A @'Const' m@ is not 'Applicative' unless its @m@ is a 'Monoid', but it is an instance of 'Apply' +instance Semigroup m => Apply (Const m) where + Const m <.> Const n = Const (m <> n) + Const m <. Const n = Const (m <> n) + Const m .> Const n = Const (m <> n) + +instance Apply ((->)m) where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply ZipList where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply [] where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply IO where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply Maybe where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply Identity where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply w => Apply (IdentityT w) where + IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb) + +instance Monad m => Apply (WrappedMonad m) where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Arrow a => Apply (WrappedArrow a b) where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +instance Apply Complex where + (a :+ b) <.> (c :+ d) = a c :+ b d + +-- | A 'Map k' is not 'Applicative', but it is an instance of 'Apply' +instance Ord k => Apply (Map k) where + (<.>) = Map.intersectionWith id + (<. ) = Map.intersectionWith const + ( .>) = Map.intersectionWith (const id) + +-- | An 'IntMap' is not 'Applicative', but it is an instance of 'Apply' +instance Apply IntMap.IntMap where + (<.>) = IntMap.intersectionWith id + (<. ) = IntMap.intersectionWith const + ( .>) = IntMap.intersectionWith (const id) + +instance Apply Tree where + (<.>) = (<*>) + (<. ) = (<* ) + ( .>) = ( *>) + +-- MaybeT is _not_ the same as Compose f Maybe +instance (Functor m, Monad m) => Apply (MaybeT m) where + (<.>) = apDefault + +instance (Functor m, Monad m) => Apply (ExceptT e m) where + (<.>) = apDefault + +instance Apply m => Apply (ReaderT e m) where + ReaderT f <.> ReaderT a = ReaderT $ \e -> f e <.> a e + +-- unfortunately, WriterT has its wrapped product in the wrong order to just use (<.>) instead of flap +-- | A @'Strict.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' +instance (Apply m, Semigroup w) => Apply (Strict.WriterT w m) where + Strict.WriterT f <.> Strict.WriterT a = Strict.WriterT $ flap <$> f <.> a where + flap (x,m) (y,n) = (x y, m <> n) + +-- | A @'Lazy.WriterT' w m@ is not 'Applicative' unless its @w@ is a 'Monoid', but it is an instance of 'Apply' +instance (Apply m, Semigroup w) => Apply (Lazy.WriterT w m) where + Lazy.WriterT f <.> Lazy.WriterT a = Lazy.WriterT $ flap <$> f <.> a where + flap ~(x,m) ~(y,n) = (x y, m <> n) + +instance Apply (ContT r m) where + ContT f <.> ContT v = ContT $ \k -> f $ \g -> v (k . g) + +-- | Wrap an 'Applicative' to be used as a member of 'Apply' +newtype WrappedApplicative f a = WrapApplicative { unwrapApplicative :: f a } + +instance Functor f => Functor (WrappedApplicative f) where + fmap f (WrapApplicative a) = WrapApplicative (f <$> a) + +instance Applicative f => Apply (WrappedApplicative f) where + WrapApplicative f <.> WrapApplicative a = WrapApplicative (f <*> a) + WrapApplicative a <. WrapApplicative b = WrapApplicative (a <* b) + WrapApplicative a .> WrapApplicative b = WrapApplicative (a *> b) + +instance Applicative f => Applicative (WrappedApplicative f) where + pure = WrapApplicative . pure + WrapApplicative f <*> WrapApplicative a = WrapApplicative (f <*> a) + WrapApplicative a <* WrapApplicative b = WrapApplicative (a <* b) + WrapApplicative a *> WrapApplicative b = WrapApplicative (a *> b) + +instance Alternative f => Alternative (WrappedApplicative f) where + empty = WrapApplicative empty + WrapApplicative a <|> WrapApplicative b = WrapApplicative (a <|> b) + +-- | Transform an Apply into an Applicative by adding a unit. +newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a } + +-- | Apply a non-empty container of functions to a possibly-empty-with-unit container of values. +(<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b +ff <.*> MaybeApply (Left fa) = ff <.> fa +ff <.*> MaybeApply (Right a) = ($ a) <$> ff +infixl 4 <.*> + +-- | Apply a possibly-empty-with-unit container of functions to a non-empty container of values. +(<*.>) :: (Apply f) => MaybeApply f (a -> b) -> f a -> f b +MaybeApply (Left ff) <*.> fa = ff <.> fa +MaybeApply (Right f) <*.> fa = f <$> fa +infixl 4 <*.> + +-- | Traverse a 'Traversable' using 'Apply', getting the results back in a 'MaybeApply'. +traverse1Maybe :: (Traversable t, Apply f) => (a -> f b) -> t a -> MaybeApply f (t b) +traverse1Maybe f = traverse (MaybeApply . Left . f) + +instance Functor f => Functor (MaybeApply f) where + fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a )) + fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa)) + +instance Apply f => Apply (MaybeApply f) where + MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a )) + MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa)) + MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($ a) <$> ff)) + MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa)) + + MaybeApply a <. MaybeApply (Right _) = MaybeApply a + MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb)) + MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb)) + + MaybeApply (Right _) .> MaybeApply b = MaybeApply b + MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b )) + MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb)) + +instance Apply f => Applicative (MaybeApply f) where + pure a = MaybeApply (Right a) + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +instance Apply Down where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) + +instance Apply Monoid.Sum where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Monoid.Product where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Monoid.Dual where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Monoid.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Monoid.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +deriving instance Apply f => Apply (Monoid.Alt f) +-- in GHC 8.6 we'll have to deal with Apply f => Apply (Ap f) the same way +instance Apply Semigroup.First where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Semigroup.Last where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Semigroup.Min where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) +instance Apply Semigroup.Max where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) + +instance (Apply f, Apply g) => Apply (f :*: g) where + (a :*: b) <.> (c :*: d) = (a <.> c) :*: (b <.> d) + +deriving instance Apply f => Apply (M1 i t f) +deriving instance Apply f => Apply (Rec1 f) + +instance (Apply f, Apply g) => Apply (f :.: g) where + Comp1 m <.> Comp1 n = Comp1 $ (<.>) <$> m <.> n + +instance Apply U1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) + +-- | A @'K1' i c@ is not 'Applicative' unless its @c@ is a 'Monoid', but it is an instance of 'Apply' +instance Semigroup c => Apply (K1 i c) where + K1 a <.> K1 b = K1 (a <> b) + K1 a <. K1 b = K1 (a <> b) + K1 a .> K1 b = K1 (a <> b) +instance Apply Par1 where (<.>)=(<*>);(.>)=(*>);(<.)=(<*) + +-- | A 'V1' is not 'Applicative', but it is an instance of 'Apply' +instance Apply Generics.V1 where + e <.> _ = case e of {} +------------------------------------------------------------------------------ +-- Magma +------------------------------------------------------------------------------ + +-- | This provides a way to peek at the internal structure of a +-- 'Control.Lens.Traversal.Traversal' or 'Control.Lens.Traversal.IndexedTraversal' +data Magma i t b a where + MagmaAp :: Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a + MagmaPure :: x -> Magma i x b a + MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a + Magma :: i -> a -> Magma i b b a + +-- note the 3rd argument infers as phantom, but that would be unsound +type role Magma representational nominal nominal nominal + +instance Functor (Magma i t b) where + fmap f (MagmaAp x y) = MagmaAp (fmap f x) (fmap f y) + fmap _ (MagmaPure x) = MagmaPure x + fmap f (MagmaFmap xy x) = MagmaFmap xy (fmap f x) + fmap f (Magma i a) = Magma i (f a) + +instance Foldable (Magma i t b) where + foldMap f (MagmaAp x y) = foldMap f x `mappend` foldMap f y + foldMap _ MagmaPure{} = mempty + foldMap f (MagmaFmap _ x) = foldMap f x + foldMap f (Magma _ a) = f a + +instance Traversable (Magma i t b) where + traverse f (MagmaAp x y) = MagmaAp <$> traverse f x <*> traverse f y + traverse _ (MagmaPure x) = pure (MagmaPure x) + traverse f (MagmaFmap xy x) = MagmaFmap xy <$> traverse f x + traverse f (Magma i a) = Magma i <$> f a + +instance (Show i, Show a) => Show (Magma i t b a) where + showsPrec d (MagmaAp x y) = showParen (d > 4) $ + showsPrec 4 x . showString " <*> " . showsPrec 5 y + showsPrec d (MagmaPure _) = showParen (d > 10) $ + showString "pure .." + showsPrec d (MagmaFmap _ x) = showParen (d > 4) $ + showString ".. <$> " . showsPrec 5 x + showsPrec d (Magma i a) = showParen (d > 10) $ + showString "Magma " . showsPrec 11 i . showChar ' ' . showsPrec 11 a + +-- | Run a 'Magma' where all the individual leaves have been converted to the +-- expected type +runMagma :: Magma i t a a -> t +runMagma (MagmaAp l r) = runMagma l (runMagma r) +runMagma (MagmaFmap f r) = f (runMagma r) +runMagma (MagmaPure x) = x +runMagma (Magma _ a) = a + +------------------------------------------------------------------------------ +-- Molten +------------------------------------------------------------------------------ + +-- | This is a a non-reassociating initially encoded version of 'Bazaar'. +newtype Molten i a b t = Molten { runMolten :: Magma i t b a } + +instance Functor (Molten i a b) where + fmap f (Molten xs) = Molten (MagmaFmap f xs) + {-# INLINE fmap #-} + +instance Apply (Molten i a b) where + (<.>) = (<*>) + {-# INLINE (<.>) #-} + +instance Applicative (Molten i a b) where + pure = Molten #. MagmaPure + {-# INLINE pure #-} + Molten xs <*> Molten ys = Molten (MagmaAp xs ys) + {-# INLINE (<*>) #-} + +------------------------------------------------------------------------------ +-- Mafic +------------------------------------------------------------------------------ + +-- | This is used to generate an indexed magma from an unindexed source +-- +-- By constructing it this way we avoid infinite reassociations in sums where possible. +data Mafic a b t = Mafic Int (Int -> Magma Int t b a) + +-- | Generate a 'Magma' using from a prefix sum. +runMafic :: Mafic a b t -> Magma Int t b a +runMafic (Mafic _ k) = k 0 + +instance Functor (Mafic a b) where + fmap f (Mafic w k) = Mafic w (MagmaFmap f . k) + {-# INLINE fmap #-} + +instance Apply (Mafic a b) where + Mafic wf mf <.> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf)) + {-# INLINE (<.>) #-} + +instance Applicative (Mafic a b) where + pure a = Mafic 0 $ \_ -> MagmaPure a + {-# INLINE pure #-} + Mafic wf mf <*> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf)) + {-# INLINE (<*>) #-} + +------------------------------------------------------------------------------ +-- TakingWhile +------------------------------------------------------------------------------ + +-- | This is used to generate an indexed magma from an unindexed source +-- +-- By constructing it this way we avoid infinite reassociations where possible. +-- +-- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant', +-- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma' +data TakingWhile p (g :: Type -> Type) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a)) +type role TakingWhile nominal nominal nominal nominal nominal + +-- | Generate a 'Magma' with leaves only while the predicate holds from left to right. +runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a) +runTakingWhile (TakingWhile _ _ k) = k True + +instance Functor (TakingWhile p f a b) where + fmap f (TakingWhile w t k) = let ft = f t in TakingWhile w ft $ \b -> if b then MagmaFmap f (k b) else MagmaPure ft + {-# INLINE fmap #-} + +instance Apply (TakingWhile p f a b) where + TakingWhile wf tf mf <.> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o -> + if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta) + {-# INLINE (<.>) #-} + +instance Applicative (TakingWhile p f a b) where + pure a = TakingWhile True a $ \_ -> MagmaPure a + {-# INLINE pure #-} + TakingWhile wf tf mf <*> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o -> + if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta) + {-# INLINE (<*>) #-} + + + +-- This constraint is unused intentionally, it protects TakingWhile +instance Contravariant f => Contravariant (TakingWhile p f a b) where + contramap _ = (<$) (error "contramap: TakingWhile") + {-# INLINE contramap #-} + +------------------------------------------------------------------------------ +-- Folding +------------------------------------------------------------------------------ + +-- | A 'Monoid' for a 'Contravariant' 'Applicative'. +newtype Folding f a = Folding { getFolding :: f a } + +instance (Contravariant f, Applicative f) => Semigroup (Folding f a) where + Folding fr <> Folding fs = Folding (fr *> fs) + {-# INLINE (<>) #-} + +instance (Contravariant f, Applicative f) => Monoid (Folding f a) where + mempty = Folding noEffect + {-# INLINE mempty #-} + +------------------------------------------------------------------------------ +-- Traversed +------------------------------------------------------------------------------ + +-- | Used internally by 'Control.Lens.Traversal.traverseOf_' and the like. +-- +-- The argument 'a' of the result should not be used! +newtype Traversed a f = Traversed { getTraversed :: f a } + +-- See 4.16 Changelog entry for the explanation of "why not Apply f =>"? +instance Applicative f => Semigroup (Traversed a f) where + Traversed ma <> Traversed mb = Traversed (ma *> mb) + {-# INLINE (<>) #-} + +instance Applicative f => Monoid (Traversed a f) where + mempty = Traversed (pure (error "Traversed: value used")) + {-# INLINE mempty #-} + +------------------------------------------------------------------------------ +-- TraversedF +------------------------------------------------------------------------------ + +-- | Used internally by 'Control.Lens.Fold.traverse1Of_' and the like. +-- +-- @since 4.16 +newtype TraversedF a f = TraversedF { getTraversedF :: f a } + +instance Apply f => Semigroup (TraversedF a f) where + TraversedF ma <> TraversedF mb = TraversedF (ma .> mb) + {-# INLINE (<>) #-} + +instance (Apply f, Applicative f) => Monoid (TraversedF a f) where + mempty = TraversedF (pure (error "TraversedF: value used")) + {-# INLINE mempty #-} + +------------------------------------------------------------------------------ +-- Sequenced +------------------------------------------------------------------------------ + +-- | Used internally by 'Control.Lens.Traversal.mapM_' and the like. +-- +-- The argument 'a' of the result should not be used! +-- +-- See 4.16 Changelog entry for the explanation of "why not Apply f =>"? +newtype Sequenced a m = Sequenced { getSequenced :: m a } + +instance Monad m => Semigroup (Sequenced a m) where + Sequenced ma <> Sequenced mb = Sequenced (ma >> mb) + {-# INLINE (<>) #-} + +instance Monad m => Monoid (Sequenced a m) where + mempty = Sequenced (return (error "Sequenced: value used")) + {-# INLINE mempty #-} + +------------------------------------------------------------------------------ +-- NonEmptyDList +------------------------------------------------------------------------------ + +newtype NonEmptyDList a + = NonEmptyDList { getNonEmptyDList :: [a] -> NonEmpty.NonEmpty a } + +instance Semigroup (NonEmptyDList a) where + NonEmptyDList f <> NonEmptyDList g = NonEmptyDList (f . NonEmpty.toList . g) + +------------------------------------------------------------------------------ +-- Leftmost and Rightmost +------------------------------------------------------------------------------ + +-- | Used for 'Control.Lens.Fold.firstOf'. +data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) + +instance Semigroup (Leftmost a) where + x <> y = LStep $ case x of + LPure -> y + LLeaf _ -> x + LStep x' -> case y of + -- The last two cases make firstOf produce a Just as soon as any element + -- is encountered, and possibly serve as a micro-optimisation; this + -- behaviour can be disabled by replacing them with _ -> x <> y'. + -- Note that this means that firstOf (backwards folded) [1..] is Just _|_. + LPure -> x' + LLeaf a -> LLeaf $ fromMaybe a (getLeftmost x') + LStep y' -> mappend x' y' + +instance Monoid (Leftmost a) where + mempty = LPure + {-# INLINE mempty #-} + +-- | Extract the 'Leftmost' element. This will fairly eagerly determine that it can return 'Just' +-- the moment it sees any element at all. +getLeftmost :: Leftmost a -> Maybe a +getLeftmost LPure = Nothing +getLeftmost (LLeaf a) = Just a +getLeftmost (LStep x) = getLeftmost x + +-- | Used for 'Control.Lens.Fold.lastOf'. +data Rightmost a = RPure | RLeaf a | RStep (Rightmost a) + +instance Semigroup (Rightmost a) where + x <> y = RStep $ case y of + RPure -> x + RLeaf _ -> y + RStep y' -> case x of + -- The last two cases make lastOf produce a Just as soon as any element + -- is encountered, and possibly serve as a micro-optimisation; this + -- behaviour can be disabled by replacing them with _ -> x <> y'. + -- Note that this means that lastOf folded [1..] is Just _|_. + RPure -> y' + RLeaf a -> RLeaf $ fromMaybe a (getRightmost y') + RStep x' -> mappend x' y' + +instance Monoid (Rightmost a) where + mempty = RPure + {-# INLINE mempty #-} + +-- | Extract the 'Rightmost' element. This will fairly eagerly determine that it can return 'Just' +-- the moment it sees any element at all. +getRightmost :: Rightmost a -> Maybe a +getRightmost RPure = Nothing +getRightmost (RLeaf a) = Just a +getRightmost (RStep x) = getRightmost x + +------------------------------------------------------------------------------- +-- Getters +------------------------------------------------------------------------------- + +-- | Build an (index-preserving) 'Getter' from an arbitrary Haskell function. +-- +-- @ +-- 'to' f '.' 'to' g ≡ 'to' (g '.' f) +-- @ +-- +-- @ +-- a '^.' 'to' f ≡ f a +-- @ +-- +-- >>> a ^.to f +-- f a +-- +-- >>> ("hello","world")^.to snd +-- "world" +-- +-- >>> 5^.to succ +-- 6 +-- +-- >>> (0, -5)^._2.to abs +-- 5 +-- +-- @ +-- 'to' :: (s -> a) -> 'IndexPreservingGetter' s a +-- @ +to :: (Profunctor p, Contravariant f) => (s -> a) -> Optic' p f s a +to k = dimap k (contramap k) +{-# INLINE to #-} + +-- | +-- @ +-- 'ito' :: (s -> (i, a)) -> 'IndexedGetter' i s a +-- @ +ito :: (Indexable i p, Contravariant f) => (s -> (i, a)) -> Over' p f s a +ito k = dimap k (contramap (snd . k)) . uncurry . indexed +{-# INLINE ito #-} + + +-- | Build an constant-valued (index-preserving) 'Getter' from an arbitrary Haskell value. +-- +-- @ +-- 'like' a '.' 'like' b ≡ 'like' b +-- a '^.' 'like' b ≡ b +-- a '^.' 'like' b ≡ a '^.' 'to' ('const' b) +-- @ +-- +-- This can be useful as a second case 'failing' a 'Fold' +-- e.g. @foo `failing` 'like' 0@ +-- +-- @ +-- 'like' :: a -> 'IndexPreservingGetter' s a +-- @ +like :: (Profunctor p, Contravariant f, Functor f) => a -> Optic' p f s a +like a = to (const a) +{-# INLINE like #-} + +-- | +-- @ +-- 'ilike' :: i -> a -> 'IndexedGetter' i s a +-- @ +ilike :: (Indexable i p, Contravariant f, Functor f) => i -> a -> Over' p f s a +ilike i a = ito (const (i, a)) +{-# INLINE ilike #-} + +-- | When you see this in a type signature it indicates that you can +-- pass the function a 'Lens', 'Getter', +-- 'Control.Lens.Traversal.Traversal', 'Control.Lens.Fold.Fold', +-- 'Control.Lens.Prism.Prism', 'Control.Lens.Iso.Iso', or one of +-- the indexed variants, and it will just \"do the right thing\". +-- +-- Most 'Getter' combinators are able to be used with both a 'Getter' or a +-- 'Control.Lens.Fold.Fold' in limited situations, to do so, they need to be +-- monomorphic in what we are going to extract with 'Control.Applicative.Const'. To be compatible +-- with 'Lens', 'Control.Lens.Traversal.Traversal' and +-- 'Control.Lens.Iso.Iso' we also restricted choices of the irrelevant @t@ and +-- @b@ parameters. +-- +-- If a function accepts a @'Getting' r s a@, then when @r@ is a 'Data.Monoid.Monoid', then +-- you can pass a 'Control.Lens.Fold.Fold' (or +-- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a +-- 'Getter' or 'Lens'. +type Getting r s a = (a -> Const r a) -> s -> Const r s + +-- | Used to consume an 'Control.Lens.Fold.IndexedFold'. +type IndexedGetting i m s a = Indexed i a (Const m a) -> s -> Const m s + +-- | This is a convenient alias used when consuming (indexed) getters and (indexed) folds +-- in a highly general fashion. +type Accessing p m s a = p a (Const m a) -> s -> Const m s + +------------------------------------------------------------------------------- +-- Getting Values +------------------------------------------------------------------------------- + +-- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or +-- 'Lens' or the result of folding over all the results of a +-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points +-- at a monoidal value. +-- +-- @ +-- 'view' '.' 'to' ≡ 'id' +-- @ +-- +-- >>> view (to f) a +-- f a +-- +-- >>> view _2 (1,"hello") +-- "hello" +-- +-- >>> view (to succ) 5 +-- 6 +-- +-- >>> view (_2._1) ("hello",("world","!!!")) +-- "world" +-- +-- +-- As 'view' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', +-- It may be useful to think of it as having one of these more restricted signatures: +-- +-- @ +-- 'view' :: 'Getter' s a -> s -> a +-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s m -> s -> m +-- 'view' :: 'Control.Lens.Iso.Iso'' s a -> s -> a +-- 'view' :: 'Lens'' s a -> s -> a +-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s m -> s -> m +-- @ +-- +-- In a more general setting, such as when working with a 'Monad' transformer stack you can use: +-- +-- @ +-- 'view' :: 'MonadReader' s m => 'Getter' s a -> m a +-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Fold.Fold' s a -> m a +-- 'view' :: 'MonadReader' s m => 'Control.Lens.Iso.Iso'' s a -> m a +-- 'view' :: 'MonadReader' s m => 'Lens'' s a -> m a +-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> m a +-- @ +view :: MonadReader s m => Getting a s a -> m a +view l = Reader.asks (getConst #. l Const) +{-# INLINE view #-} + +-- | View a function of the value pointed to by a 'Getter' or 'Lens' or the result of +-- folding over the result of mapping the targets of a 'Control.Lens.Fold.Fold' or +-- 'Control.Lens.Traversal.Traversal'. +-- +-- @ +-- 'views' l f ≡ 'view' (l '.' 'to' f) +-- @ +-- +-- >>> views (to f) g a +-- g (f a) +-- +-- >>> views _2 length (1,"hello") +-- 5 +-- +-- As 'views' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold', +-- It may be useful to think of it as having one of these more restricted signatures: +-- +-- @ +-- 'views' :: 'Getter' s a -> (a -> r) -> s -> r +-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s a -> (a -> m) -> s -> m +-- 'views' :: 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> s -> r +-- 'views' :: 'Lens'' s a -> (a -> r) -> s -> r +-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s a -> (a -> m) -> s -> m +-- @ +-- +-- In a more general setting, such as when working with a 'Monad' transformer stack you can use: +-- +-- @ +-- 'views' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m r +-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r +-- 'views' :: 'MonadReader' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> m r +-- 'views' :: 'MonadReader' s m => 'Lens'' s a -> (a -> r) -> m r +-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r +-- @ +-- +-- @ +-- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r +-- @ +views :: MonadReader s m => LensLike' (Const r) s a -> (a -> r) -> m r +views l f = Reader.asks (coerce l f) +{-# INLINE views #-} + +-- | View the value pointed to by a 'Getter' or 'Lens' or the +-- result of folding over all the results of a 'Control.Lens.Fold.Fold' or +-- 'Control.Lens.Traversal.Traversal' that points at a monoidal values. +-- +-- This is the same operation as 'view' with the arguments flipped. +-- +-- The fixity and semantics are such that subsequent field accesses can be +-- performed with ('Prelude..'). +-- +-- >>> (a,b)^._2 +-- b +-- +-- >>> ("hello","world")^._2 +-- "world" +-- +-- >>> import Data.Complex +-- >>> ((0, 1 :+ 2), 3)^._1._2.to magnitude +-- 2.23606797749979 +-- +-- @ +-- ('^.') :: s -> 'Getter' s a -> a +-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Fold.Fold' s m -> m +-- ('^.') :: s -> 'Control.Lens.Iso.Iso'' s a -> a +-- ('^.') :: s -> 'Lens'' s a -> a +-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Traversal.Traversal'' s m -> m +-- @ +(^.) :: s -> Getting a s a -> a +s ^. l = getConst (l Const s) +{-# INLINE (^.) #-} + +------------------------------------------------------------------------------- +-- MonadState +------------------------------------------------------------------------------- + +-- | Use the target of a 'Lens', 'Control.Lens.Iso.Iso', or +-- 'Getter' in the current state, or use a summary of a +-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points +-- to a monoidal value. +-- +-- >>> evalState (use _1) (a,b) +-- a +-- +-- >>> evalState (use _1) ("hello","world") +-- "hello" +-- +-- @ +-- 'use' :: 'MonadState' s m => 'Getter' s a -> m a +-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s r -> m r +-- 'use' :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> m a +-- 'use' :: 'MonadState' s m => 'Lens'' s a -> m a +-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s r -> m r +-- @ +use :: MonadState s m => Getting a s a -> m a +use l = State.gets (view l) +{-# INLINE use #-} + +-- | Use the target of a 'Lens', 'Control.Lens.Iso.Iso' or +-- 'Getter' in the current state, or use a summary of a +-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that +-- points to a monoidal value. +-- +-- >>> evalState (uses _1 length) ("hello","world") +-- 5 +-- +-- @ +-- 'uses' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m r +-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a -> (a -> r) -> m r +-- 'uses' :: 'MonadState' s m => 'Lens'' s a -> (a -> r) -> m r +-- 'uses' :: 'MonadState' s m => 'Control.Lens.Iso.Iso'' s a -> (a -> r) -> m r +-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r +-- @ +-- +-- @ +-- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r +-- @ +uses :: MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r +uses l f = State.gets (views l f) +{-# INLINE uses #-} + +-- | This is a generalized form of 'listen' that only extracts the portion of +-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal' +-- then a monoidal summary of the parts of the log that are visited will be +-- returned. +-- +-- @ +-- 'listening' :: 'MonadWriter' w m => 'Getter' w u -> m a -> m (a, u) +-- 'listening' :: 'MonadWriter' w m => 'Lens'' w u -> m a -> m (a, u) +-- 'listening' :: 'MonadWriter' w m => 'Iso'' w u -> m a -> m (a, u) +-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Fold' w u -> m a -> m (a, u) +-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Traversal'' w u -> m a -> m (a, u) +-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Prism'' w u -> m a -> m (a, u) +-- @ +listening :: MonadWriter w m => Getting u w u -> m a -> m (a, u) +listening l m = do + (a, w) <- listen m + return (a, view l w) +{-# INLINE listening #-} + +-- | This is a generalized form of 'listen' that only extracts the portion of +-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal' +-- then a monoidal summary of the parts of the log that are visited will be +-- returned. +-- +-- @ +-- 'ilistening' :: 'MonadWriter' w m => 'IndexedGetter' i w u -> m a -> m (a, (i, u)) +-- 'ilistening' :: 'MonadWriter' w m => 'IndexedLens'' i w u -> m a -> m (a, (i, u)) +-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedFold' i w u -> m a -> m (a, (i, u)) +-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedTraversal'' i w u -> m a -> m (a, (i, u)) +-- @ +ilistening :: MonadWriter w m => IndexedGetting i (i, u) w u -> m a -> m (a, (i, u)) +ilistening l m = do + (a, w) <- listen m + return (a, iview l w) +{-# INLINE ilistening #-} + +-- | This is a generalized form of 'listen' that only extracts the portion of +-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal' +-- then a monoidal summary of the parts of the log that are visited will be +-- returned. +-- +-- @ +-- 'listenings' :: 'MonadWriter' w m => 'Getter' w u -> (u -> v) -> m a -> m (a, v) +-- 'listenings' :: 'MonadWriter' w m => 'Lens'' w u -> (u -> v) -> m a -> m (a, v) +-- 'listenings' :: 'MonadWriter' w m => 'Iso'' w u -> (u -> v) -> m a -> m (a, v) +-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Fold' w u -> (u -> v) -> m a -> m (a, v) +-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Traversal'' w u -> (u -> v) -> m a -> m (a, v) +-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Prism'' w u -> (u -> v) -> m a -> m (a, v) +-- @ +listenings :: MonadWriter w m => Getting v w u -> (u -> v) -> m a -> m (a, v) +listenings l uv m = do + (a, w) <- listen m + return (a, views l uv w) +{-# INLINE listenings #-} + +-- | This is a generalized form of 'listen' that only extracts the portion of +-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal' +-- then a monoidal summary of the parts of the log that are visited will be +-- returned. +-- +-- @ +-- 'ilistenings' :: 'MonadWriter' w m => 'IndexedGetter' w u -> (i -> u -> v) -> m a -> m (a, v) +-- 'ilistenings' :: 'MonadWriter' w m => 'IndexedLens'' w u -> (i -> u -> v) -> m a -> m (a, v) +-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedFold' w u -> (i -> u -> v) -> m a -> m (a, v) +-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedTraversal'' w u -> (i -> u -> v) -> m a -> m (a, v) +-- @ +ilistenings :: MonadWriter w m => IndexedGetting i v w u -> (i -> u -> v) -> m a -> m (a, v) +ilistenings l iuv m = do + (a, w) <- listen m + return (a, iviews l iuv w) +{-# INLINE ilistenings #-} + +------------------------------------------------------------------------------ +-- Indexed Getters +------------------------------------------------------------------------------ + +-- | View the index and value of an 'IndexedGetter' into the current environment as a pair. +-- +-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of +-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. +iview :: MonadReader s m => IndexedGetting i (i,a) s a -> m (i,a) +iview l = asks (getConst #. l (Indexed $ \i -> Const #. (,) i)) +{-# INLINE iview #-} + +-- | View a function of the index and value of an 'IndexedGetter' into the current environment. +-- +-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. +-- +-- @ +-- 'iviews' ≡ 'Control.Lens.Fold.ifoldMapOf' +-- @ +iviews :: MonadReader s m => IndexedGetting i r s a -> (i -> a -> r) -> m r +iviews l f = asks (coerce l f) +{-# INLINE iviews #-} + +-- | Use the index and value of an 'IndexedGetter' into the current state as a pair. +-- +-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of +-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted. +iuse :: MonadState s m => IndexedGetting i (i,a) s a -> m (i,a) +iuse l = gets (getConst #. l (Indexed $ \i -> Const #. (,) i)) +{-# INLINE iuse #-} + +-- | Use a function of the index and value of an 'IndexedGetter' into the current state. +-- +-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer. +iuses :: MonadState s m => IndexedGetting i r s a -> (i -> a -> r) -> m r +iuses l f = gets (coerce l f) +{-# INLINE iuses #-} + +-- | View the index and value of an 'IndexedGetter' or 'IndexedLens'. +-- +-- This is the same operation as 'iview' with the arguments flipped. +-- +-- The fixity and semantics are such that subsequent field accesses can be +-- performed with ('Prelude..'). +-- +-- @ +-- ('^@.') :: s -> 'IndexedGetter' i s a -> (i, a) +-- ('^@.') :: s -> 'IndexedLens'' i s a -> (i, a) +-- @ +-- +-- The result probably doesn't have much meaning when applied to an 'IndexedFold'. +(^@.) :: s -> IndexedGetting i (i, a) s a -> (i, a) +s ^@. l = getConst $ l (Indexed $ \i -> Const #. (,) i) s +{-# INLINE (^@.) #-} + +-- | Coerce a 'Getter'-compatible 'Optical' to an 'Optical''. This +-- is useful when using a 'Traversal' that is not simple as a 'Getter' or a +-- 'Fold'. +-- +-- @ +-- 'getting' :: 'Traversal' s t a b -> 'Fold' s a +-- 'getting' :: 'Lens' s t a b -> 'Getter' s a +-- 'getting' :: 'IndexedTraversal' i s t a b -> 'IndexedFold' i s a +-- 'getting' :: 'IndexedLens' i s t a b -> 'IndexedGetter' i s a +-- @ +getting :: (Profunctor p, Profunctor q, Functor f, Contravariant f) + => Optical p q f s t a b -> Optical' p q f s a +getting l f = rmap phantom . l $ rmap phantom f + +---------------------------------------------------------------------------- +-- Profunctors +---------------------------------------------------------------------------- + +-- | Formally, the class 'Profunctor' represents a profunctor +-- from @Hask@ -> @Hask@. +-- +-- Intuitively it is a bifunctor where the first argument is contravariant +-- and the second argument is covariant. +-- +-- You can define a 'Profunctor' by either defining 'dimap' or by defining both +-- 'lmap' and 'rmap'. +-- +-- If you supply 'dimap', you should ensure that: +-- +-- @'dimap' 'id' 'id' ≡ 'id'@ +-- +-- If you supply 'lmap' and 'rmap', ensure: +-- +-- @ +-- 'lmap' 'id' ≡ 'id' +-- 'rmap' 'id' ≡ 'id' +-- @ +-- +-- If you supply both, you should also ensure: +-- +-- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ +-- +-- These ensure by parametricity: +-- +-- @ +-- 'dimap' (f '.' g) (h '.' i) ≡ 'dimap' g h '.' 'dimap' f i +-- 'lmap' (f '.' g) ≡ 'lmap' g '.' 'lmap' f +-- 'rmap' (f '.' g) ≡ 'rmap' f '.' 'rmap' g +-- @ +class Profunctor p where + -- | Map over both arguments at the same time. + -- + -- @'dimap' f g ≡ 'lmap' f '.' 'rmap' g@ + dimap :: (a -> b) -> (c -> d) -> p b c -> p a d + dimap f g = lmap f . rmap g + {-# INLINE dimap #-} + + -- | Map the first argument contravariantly. + -- + -- @'lmap' f ≡ 'dimap' f 'id'@ + lmap :: (a -> b) -> p b c -> p a c + lmap f = dimap f id + {-# INLINE lmap #-} + + -- | Map the second argument covariantly. + -- + -- @'rmap' ≡ 'dimap' 'id'@ + rmap :: (b -> c) -> p a b -> p a c + rmap = dimap id + {-# INLINE rmap #-} + + -- | Strictly map the second argument argument + -- covariantly with a function that is assumed + -- operationally to be a cast, such as a newtype + -- constructor. + -- + -- /Note:/ This operation is explicitly /unsafe/ + -- since an implementation may choose to use + -- 'unsafeCoerce' to implement this combinator + -- and it has no way to validate that your function + -- meets the requirements. + -- + -- If you implement this combinator with + -- 'unsafeCoerce', then you are taking upon yourself + -- the obligation that you don't use GADT-like + -- tricks to distinguish values. + -- + -- If you import "Data.Profunctor.Unsafe" you are + -- taking upon yourself the obligation that you + -- will only call this with a first argument that is + -- operationally identity. + -- + -- The semantics of this function with respect to bottoms + -- should match the default definition: + -- + -- @('Profuctor.Unsafe.#.') ≡ \\_ -> \\p -> p \`seq\` 'rmap' 'coerce' p@ + (#.) :: forall a b c q. Coercible c b => q b c -> p a b -> p a c + (#.) = \_ -> \p -> p `seq` rmap (coerce (id :: c -> c) :: b -> c) p + {-# INLINE (#.) #-} + + -- | Strictly map the first argument argument + -- contravariantly with a function that is assumed + -- operationally to be a cast, such as a newtype + -- constructor. + -- + -- /Note:/ This operation is explicitly /unsafe/ + -- since an implementation may choose to use + -- 'unsafeCoerce' to implement this combinator + -- and it has no way to validate that your function + -- meets the requirements. + -- + -- If you implement this combinator with + -- 'unsafeCoerce', then you are taking upon yourself + -- the obligation that you don't use GADT-like + -- tricks to distinguish values. + -- + -- If you import "Data.Profunctor.Unsafe" you are + -- taking upon yourself the obligation that you + -- will only call this with a second argument that is + -- operationally identity. + -- + -- @('.#') ≡ \\p -> p \`seq\` \\f -> 'lmap' 'coerce' p@ + (.#) :: forall a b c q. Coercible b a => p b c -> q a b -> p a c + (.#) = \p -> p `seq` \_ -> lmap (coerce (id :: b -> b) :: a -> b) p + {-# INLINE (.#) #-} + + {-# MINIMAL dimap | (lmap, rmap) #-} + +------------------------------------------------------------------------------ +-- Conjoined +------------------------------------------------------------------------------ + +-- | This is a 'Profunctor' that is both 'Corepresentable' by @f@ and 'Representable' by @g@ such +-- that @f@ is left adjoint to @g@. From this you can derive a lot of structure due +-- to the preservation of limits and colimits. +class + ( Choice p, Corepresentable p, Comonad (Corep p), Traversable (Corep p) + , Strong p, Representable p, Monad (Rep p), MonadFix (Rep p), Costrong p, ArrowLoop p, ArrowApply p, ArrowChoice p + ) => Conjoined p where + + -- | 'Conjoined' is strong enough to let us distribute every 'Conjoined' + -- 'Profunctor' over every Haskell 'Functor'. This is effectively a + -- generalization of 'fmap'. + distrib :: Functor f => p a b -> p (f a) (f b) + distrib = tabulate . collect . sieve + {-# INLINE distrib #-} + + -- | This permits us to make a decision at an outermost point about whether or not we use an index. + -- + -- Ideally any use of this function should be done in such a way so that you compute the same answer, + -- but this cannot be enforced at the type level. + conjoined :: ((p ~ (->)) => q (a -> b) r) -> q (p a b) r -> q (p a b) r + conjoined _ r = r + {-# INLINE conjoined #-} + +instance Conjoined (->) where + distrib = fmap + {-# INLINE distrib #-} + conjoined l _ = l + {-# INLINE conjoined #-} + +---------------------------------------------------------------------------- +-- Indexable +---------------------------------------------------------------------------- + +-- | This class permits overloading of function application for things that +-- also admit a notion of a key or index. +class Conjoined p => Indexable i p where + -- | Build a function from an 'indexed' function. + indexed :: p a b -> i -> a -> b + +instance Indexable i (->) where + indexed = const + {-# INLINE indexed #-} + +----------------------------------------------------------------------------- +-- Indexed Internals +----------------------------------------------------------------------------- + +-- | A function with access to a index. This constructor may be useful when you need to store +-- an 'Indexable' in a container to avoid @ImpredicativeTypes@. +-- +-- @index :: Indexed i a b -> i -> a -> b@ +newtype Indexed i a b = Indexed { runIndexed :: i -> a -> b } + +instance Functor (Indexed i a) where + fmap g (Indexed f) = Indexed $ \i a -> g (f i a) + {-# INLINE fmap #-} + +instance Apply (Indexed i a) where + Indexed f <.> Indexed g = Indexed $ \i a -> f i a (g i a) + {-# INLINE (<.>) #-} + +instance Applicative (Indexed i a) where + pure b = Indexed $ \_ _ -> b + {-# INLINE pure #-} + Indexed f <*> Indexed g = Indexed $ \i a -> f i a (g i a) + {-# INLINE (<*>) #-} + +instance Monad (Indexed i a) where + return = pure + {-# INLINE return #-} + Indexed f >>= k = Indexed $ \i a -> runIndexed (k (f i a)) i a + {-# INLINE (>>=) #-} + +instance MonadFix (Indexed i a) where + mfix f = Indexed $ \ i a -> let o = runIndexed (f o) i a in o + {-# INLINE mfix #-} + +instance Profunctor (Indexed i) where + dimap ab cd ibc = Indexed $ \i -> cd . runIndexed ibc i . ab + {-# INLINE dimap #-} + lmap ab ibc = Indexed $ \i -> runIndexed ibc i . ab + {-# INLINE lmap #-} + rmap bc iab = Indexed $ \i -> bc . runIndexed iab i + {-# INLINE rmap #-} + (.#) ibc _ = coerce ibc + {-# INLINE (.#) #-} + (#.) _ = coerce + {-# INLINE (#.) #-} + +instance Costrong (Indexed i) where + unfirst (Indexed iadbd) = Indexed $ \i a -> let + (b, d) = iadbd i (a, d) + in b + +instance Sieve (Indexed i) ((->) i) where + sieve = flip . runIndexed + {-# INLINE sieve #-} + +instance Representable (Indexed i) where + type Rep (Indexed i) = (->) i + tabulate = Indexed . flip + {-# INLINE tabulate #-} + +instance Cosieve (Indexed i) ((,) i) where + cosieve = uncurry . runIndexed + {-# INLINE cosieve #-} + +instance Corepresentable (Indexed i) where + type Corep (Indexed i) = (,) i + cotabulate = Indexed . curry + {-# INLINE cotabulate #-} + +instance Choice (Indexed i) where + right' = right + {-# INLINE right' #-} + +instance Strong (Indexed i) where + second' = Arrow.second + {-# INLINE second' #-} + +instance C.Category (Indexed i) where + id = Indexed (const id) + {-# INLINE id #-} + Indexed f . Indexed g = Indexed $ \i -> f i . g i + {-# INLINE (.) #-} + +instance Arrow (Indexed i) where + arr f = Indexed (\_ -> f) + {-# INLINE arr #-} + first f = Indexed (Arrow.first . runIndexed f) + {-# INLINE first #-} + second f = Indexed (Arrow.second . runIndexed f) + {-# INLINE second #-} + Indexed f *** Indexed g = Indexed $ \i -> f i *** g i + {-# INLINE (***) #-} + Indexed f &&& Indexed g = Indexed $ \i -> f i &&& g i + {-# INLINE (&&&) #-} + +instance ArrowChoice (Indexed i) where + left f = Indexed (left . runIndexed f) + {-# INLINE left #-} + right f = Indexed (right . runIndexed f) + {-# INLINE right #-} + Indexed f +++ Indexed g = Indexed $ \i -> f i +++ g i + {-# INLINE (+++) #-} + Indexed f ||| Indexed g = Indexed $ \i -> f i ||| g i + {-# INLINE (|||) #-} + +instance ArrowApply (Indexed i) where + app = Indexed $ \ i (f, b) -> runIndexed f i b + {-# INLINE app #-} + +instance ArrowLoop (Indexed i) where + loop (Indexed f) = Indexed $ \i b -> let (c,d) = f i (b, d) in c + {-# INLINE loop #-} + +instance Conjoined (Indexed i) where + distrib (Indexed iab) = Indexed $ \i fa -> iab i <$> fa + {-# INLINE distrib #-} + +instance i ~ j => Indexable i (Indexed j) where + indexed = runIndexed + {-# INLINE indexed #-} + +------------------------------------------------------------------------------ +-- Indexing +------------------------------------------------------------------------------ + +-- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int'@ with a 'Functor', used +-- by 'Control.Lens.Indexed.indexed'. +newtype Indexing f a = Indexing { runIndexing :: Int -> (Int, f a) } + +instance Functor f => Functor (Indexing f) where + fmap f (Indexing m) = Indexing $ \i -> case m i of + (j, x) -> (j, fmap f x) + {-# INLINE fmap #-} + +instance Apply f => Apply (Indexing f) where + Indexing mf <.> Indexing ma = Indexing $ \i -> case mf i of + (j, ff) -> case ma j of + ~(k, fa) -> (k, ff <.> fa) + {-# INLINE (<.>) #-} + +instance Applicative f => Applicative (Indexing f) where + pure x = Indexing $ \i -> (i, pure x) + {-# INLINE pure #-} + Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of + (j, ff) -> case ma j of + ~(k, fa) -> (k, ff <*> fa) + {-# INLINE (<*>) #-} + +instance Contravariant f => Contravariant (Indexing f) where + contramap f (Indexing m) = Indexing $ \i -> case m i of + (j, ff) -> (j, contramap f ff) + {-# INLINE contramap #-} + +instance Semigroup (f a) => Semigroup (Indexing f a) where + Indexing mx <> Indexing my = Indexing $ \i -> case mx i of + (j, x) -> case my j of + ~(k, y) -> (k, x <> y) + {-# INLINE (<>) #-} + +-- | +-- +-- >>> "cat" ^@.. (folded <> folded) +-- [(0,'c'),(1,'a'),(2,'t'),(0,'c'),(1,'a'),(2,'t')] +-- +-- >>> "cat" ^@.. indexing (folded <> folded) +-- [(0,'c'),(1,'a'),(2,'t'),(3,'c'),(4,'a'),(5,'t')] +instance Monoid (f a) => Monoid (Indexing f a) where + mempty = Indexing $ \i -> (i, mempty) + {-# INLINE mempty #-} + +-- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or +-- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc. +-- +-- @ +-- 'indexing' :: 'Control.Lens.Type.Traversal' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Type.Prism' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Type.Iso' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int' s t a b +-- 'indexing' :: 'Control.Lens.Type.Fold' s a -> 'Control.Lens.Type.IndexedFold' 'Int' s a +-- 'indexing' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.IndexedGetter' 'Int' s a +-- @ +-- +-- @'indexing' :: 'Indexable' 'Int' p => 'Control.Lens.Type.LensLike' ('Indexing' f) s t a b -> 'Control.Lens.Type.Over' p f s t a b@ +indexing :: Indexable Int p => ((a -> Indexing f b) -> s -> Indexing f t) -> p a (f b) -> s -> f t +indexing l iafb s = snd $ runIndexing (l (\a -> Indexing (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 +{-# INLINE indexing #-} + +------------------------------------------------------------------------------ +-- Indexing64 +------------------------------------------------------------------------------ + +-- | 'Applicative' composition of @'Control.Monad.Trans.State.Lazy.State' 'Int64'@ with a 'Functor', used +-- by 'Control.Lens.Indexed.indexed64'. +newtype Indexing64 f a = Indexing64 { runIndexing64 :: Int64 -> (Int64, f a) } + +instance Functor f => Functor (Indexing64 f) where + fmap f (Indexing64 m) = Indexing64 $ \i -> case m i of + (j, x) -> (j, fmap f x) + {-# INLINE fmap #-} + +instance Apply f => Apply (Indexing64 f) where + Indexing64 mf <.> Indexing64 ma = Indexing64 $ \i -> case mf i of + (j, ff) -> case ma j of + ~(k, fa) -> (k, ff <.> fa) + {-# INLINE (<.>) #-} + +instance Applicative f => Applicative (Indexing64 f) where + pure x = Indexing64 $ \i -> (i, pure x) + {-# INLINE pure #-} + Indexing64 mf <*> Indexing64 ma = Indexing64 $ \i -> case mf i of + (j, ff) -> case ma j of + ~(k, fa) -> (k, ff <*> fa) + {-# INLINE (<*>) #-} + +instance Contravariant f => Contravariant (Indexing64 f) where + contramap f (Indexing64 m) = Indexing64 $ \i -> case m i of + (j, ff) -> (j, contramap f ff) + {-# INLINE contramap #-} + +-- | Transform a 'Control.Lens.Traversal.Traversal' into an 'Control.Lens.Traversal.IndexedTraversal' or +-- a 'Control.Lens.Fold.Fold' into an 'Control.Lens.Fold.IndexedFold', etc. +-- +-- This combinator is like 'indexing' except that it handles large traversals and folds gracefully. +-- +-- @ +-- 'indexing64' :: 'Control.Lens.Type.Traversal' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int64' s t a b +-- 'indexing64' :: 'Control.Lens.Type.Prism' s t a b -> 'Control.Lens.Type.IndexedTraversal' 'Int64' s t a b +-- 'indexing64' :: 'Control.Lens.Type.Lens' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int64' s t a b +-- 'indexing64' :: 'Control.Lens.Type.Iso' s t a b -> 'Control.Lens.Type.IndexedLens' 'Int64' s t a b +-- 'indexing64' :: 'Control.Lens.Type.Fold' s a -> 'Control.Lens.Type.IndexedFold' 'Int64' s a +-- 'indexing64' :: 'Control.Lens.Type.Getter' s a -> 'Control.Lens.Type.IndexedGetter' 'Int64' s a +-- @ +-- +-- @'indexing64' :: 'Indexable' 'Int64' p => 'Control.Lens.Type.LensLike' ('Indexing64' f) s t a b -> 'Control.Lens.Type.Over' p f s t a b@ +indexing64 :: Indexable Int64 p => ((a -> Indexing64 f b) -> s -> Indexing64 f t) -> p a (f b) -> s -> f t +indexing64 l iafb s = snd $ runIndexing64 (l (\a -> Indexing64 (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0 +{-# INLINE indexing64 #-} + +------------------------------------------------------------------------------- +-- Converting to Folds +------------------------------------------------------------------------------- + +-- | Fold a container with indices returning both the indices and the values. +-- +-- The result is only valid to compose in a 'Traversal', if you don't edit the +-- index as edits to the index have no effect. +-- +-- >>> [10, 20, 30] ^.. ifolded . withIndex +-- [(0,10),(1,20),(2,30)] +-- +-- >>> [10, 20, 30] ^.. ifolded . withIndex . alongside negated (re _Show) +-- [(0,"10"),(-1,"20"),(-2,"30")] +-- +withIndex :: (Indexable i p, Functor f) => p (i, s) (f (j, t)) -> Indexed i s (f t) +withIndex f = Indexed $ \i a -> snd <$> indexed f i (i, a) +{-# INLINE withIndex #-} + +-- | When composed with an 'IndexedFold' or 'IndexedTraversal' this yields an +-- ('Indexed') 'Fold' of the indices. +asIndex :: (Indexable i p, Contravariant f, Functor f) => p i (f i) -> Indexed i s (f s) +asIndex f = Indexed $ \i _ -> phantom (indexed f i i) +{-# INLINE asIndex #-} + +-- | A 'Lens' is actually a lens family as described in +-- <http://comonad.com/reader/2012/mirrored-lenses/>. +-- +-- With great power comes great responsibility and a 'Lens' is subject to the +-- three common sense 'Lens' laws: +-- +-- 1) You get back what you put in: +-- +-- @ +-- 'Control.Lens.Getter.view' l ('Control.Lens.Setter.set' l v s) ≡ v +-- @ +-- +-- 2) Putting back what you got doesn't change anything: +-- +-- @ +-- 'Control.Lens.Setter.set' l ('Control.Lens.Getter.view' l s) s ≡ s +-- @ +-- +-- 3) Setting twice is the same as setting once: +-- +-- @ +-- 'Control.Lens.Setter.set' l v' ('Control.Lens.Setter.set' l v s) ≡ 'Control.Lens.Setter.set' l v' s +-- @ +-- +-- These laws are strong enough that the 4 type parameters of a 'Lens' cannot +-- vary fully independently. For more on how they interact, read the \"Why is +-- it a Lens Family?\" section of +-- <http://comonad.com/reader/2012/mirrored-lenses/>. +-- +-- There are some emergent properties of these laws: +-- +-- 1) @'Control.Lens.Setter.set' l s@ must be injective for every @s@ This is a consequence of law #1 +-- +-- 2) @'Control.Lens.Setter.set' l@ must be surjective, because of law #2, which indicates that it is possible to obtain any 'v' from some 's' such that @'Control.Lens.Setter.set' s v = s@ +-- +-- 3) Given just the first two laws you can prove a weaker form of law #3 where the values @v@ that you are setting match: +-- +-- @ +-- 'Control.Lens.Setter.set' l v ('Control.Lens.Setter.set' l v s) ≡ 'Control.Lens.Setter.set' l v s +-- @ +-- +-- Every 'Lens' can be used directly as a 'Control.Lens.Setter.Setter' or 'Traversal'. +-- +-- You can also use a 'Lens' for 'Control.Lens.Getter.Getting' as if it were a +-- 'Fold' or 'Getter'. +-- +-- Since every 'Lens' is a valid 'Traversal', the +-- 'Traversal' laws are required of any 'Lens' you create: +-- +-- @ +-- l 'pure' ≡ 'pure' +-- 'fmap' (l f) '.' l g ≡ 'Data.Functor.Compose.getCompose' '.' l ('Data.Functor.Compose.Compose' '.' 'fmap' f '.' g) +-- @ +-- +-- @ +-- type 'Lens' s t a b = forall f. 'Functor' f => 'LensLike' f s t a b +-- @ +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | @ +-- type 'Lens'' = 'Simple' 'Lens' +-- @ +type Lens' s a = Lens s s a a + +-- | Every 'IndexedLens' is a valid 'Lens' and a valid 'Control.Lens.Traversal.IndexedTraversal'. +type IndexedLens i s t a b = forall f p. (Indexable i p, Functor f) => p a (f b) -> s -> f t + +-- | @ +-- type 'IndexedLens'' i = 'Simple' ('IndexedLens' i) +-- @ +type IndexedLens' i s a = IndexedLens i s s a a + +-- | An 'IndexPreservingLens' leaves any index it is composed with alone. +type IndexPreservingLens s t a b = forall p f. (Conjoined p, Functor f) => p a (f b) -> p s (f t) + +-- | @ +-- type 'IndexPreservingLens'' = 'Simple' 'IndexPreservingLens' +-- @ +type IndexPreservingLens' s a = IndexPreservingLens s s a a + +------------------------------------------------------------------------------ +-- Traversals +------------------------------------------------------------------------------ + +-- | A 'Traversal' can be used directly as a 'Control.Lens.Setter.Setter' or a 'Fold' (but not as a 'Lens') and provides +-- the ability to both read and update multiple fields, subject to some relatively weak 'Traversal' laws. +-- +-- These have also been known as multilenses, but they have the signature and spirit of +-- +-- @ +-- 'Data.Traversable.traverse' :: 'Data.Traversable.Traversable' f => 'Traversal' (f a) (f b) a b +-- @ +-- +-- and the more evocative name suggests their application. +-- +-- Most of the time the 'Traversal' you will want to use is just 'Data.Traversable.traverse', but you can also pass any +-- 'Lens' or 'Iso' as a 'Traversal', and composition of a 'Traversal' (or 'Lens' or 'Iso') with a 'Traversal' (or 'Lens' or 'Iso') +-- using ('.') forms a valid 'Traversal'. +-- +-- The laws for a 'Traversal' @t@ follow from the laws for 'Data.Traversable.Traversable' as stated in \"The Essence of the Iterator Pattern\". +-- +-- @ +-- t 'pure' ≡ 'pure' +-- 'fmap' (t f) '.' t g ≡ 'Data.Functor.Compose.getCompose' '.' t ('Data.Functor.Compose.Compose' '.' 'fmap' f '.' g) +-- @ +-- +-- One consequence of this requirement is that a 'Traversal' needs to leave the same number of elements as a +-- candidate for subsequent 'Traversal' that it started with. Another testament to the strength of these laws +-- is that the caveat expressed in section 5.5 of the \"Essence of the Iterator Pattern\" about exotic +-- 'Data.Traversable.Traversable' instances that 'Data.Traversable.traverse' the same entry multiple times was actually already ruled out by the +-- second law in that same paper! +type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t + +-- | @ +-- type 'Traversal'' = 'Simple' 'Traversal' +-- @ +type Traversal' s a = Traversal s s a a + +-- | A 'Traversal' which targets at least one element. +-- +-- Note that since 'Apply' is not a superclass of 'Applicative', a 'Traversal1' +-- cannot always be used in place of a 'Traversal'. In such circumstances +-- 'Control.Lens.Traversal.cloneTraversal' will convert a 'Traversal1' into a 'Traversal'. +type Traversal1 s t a b = forall f. Apply f => (a -> f b) -> s -> f t +type Traversal1' s a = Traversal1 s s a a + +-- | Every 'IndexedTraversal' is a valid 'Control.Lens.Traversal.Traversal' or +-- 'Control.Lens.Fold.IndexedFold'. +-- +-- The 'Indexed' constraint is used to allow an 'IndexedTraversal' to be used +-- directly as a 'Control.Lens.Traversal.Traversal'. +-- +-- The 'Control.Lens.Traversal.Traversal' laws are still required to hold. +-- +-- In addition, the index @i@ should satisfy the requirement that it stays +-- unchanged even when modifying the value @a@, otherwise traversals like +-- 'indices' break the 'Traversal' laws. +type IndexedTraversal i s t a b = forall p f. (Indexable i p, Applicative f) => p a (f b) -> s -> f t + +-- | @ +-- type 'IndexedTraversal'' i = 'Simple' ('IndexedTraversal' i) +-- @ +type IndexedTraversal' i s a = IndexedTraversal i s s a a + +type IndexedTraversal1 i s t a b = forall p f. (Indexable i p, Apply f) => p a (f b) -> s -> f t +type IndexedTraversal1' i s a = IndexedTraversal1 i s s a a + +-- | An 'IndexPreservingLens' leaves any index it is composed with alone. +type IndexPreservingTraversal s t a b = forall p f. (Conjoined p, Applicative f) => p a (f b) -> p s (f t) + +-- | @ +-- type 'IndexPreservingTraversal'' = 'Simple' 'IndexPreservingTraversal' +-- @ +type IndexPreservingTraversal' s a = IndexPreservingTraversal s s a a + +type IndexPreservingTraversal1 s t a b = forall p f. (Conjoined p, Apply f) => p a (f b) -> p s (f t) +type IndexPreservingTraversal1' s a = IndexPreservingTraversal1 s s a a + +------------------------------------------------------------------------------ +-- Setters +------------------------------------------------------------------------------ + +-- | The only 'LensLike' law that can apply to a 'Setter' @l@ is that +-- +-- @ +-- 'Control.Lens.Setter.set' l y ('Control.Lens.Setter.set' l x a) ≡ 'Control.Lens.Setter.set' l y a +-- @ +-- +-- You can't 'Control.Lens.Getter.view' a 'Setter' in general, so the other two laws are irrelevant. +-- +-- However, two 'Functor' laws apply to a 'Setter': +-- +-- @ +-- 'Control.Lens.Setter.over' l 'id' ≡ 'id' +-- 'Control.Lens.Setter.over' l f '.' 'Control.Lens.Setter.over' l g ≡ 'Control.Lens.Setter.over' l (f '.' g) +-- @ +-- +-- These can be stated more directly: +-- +-- @ +-- l 'pure' ≡ 'pure' +-- l f '.' 'untainted' '.' l g ≡ l (f '.' 'untainted' '.' g) +-- @ +-- +-- You can compose a 'Setter' with a 'Lens' or a 'Traversal' using ('.') from the @Prelude@ +-- and the result is always only a 'Setter' and nothing more. +-- +-- >>> over traverse f [a,b,c,d] +-- [f a,f b,f c,f d] +-- +-- >>> over _1 f (a,b) +-- (f a,b) +-- +-- >>> over (traverse._1) f [(a,b),(c,d)] +-- [(f a,b),(f c,d)] +-- +-- >>> over both f (a,b) +-- (f a,f b) +-- +-- >>> over (traverse.both) f [(a,b),(c,d)] +-- [(f a,f b),(f c,f d)] +type Setter s t a b = forall f. Settable f => (a -> f b) -> s -> f t + +-- | A 'Setter'' is just a 'Setter' that doesn't change the types. +-- +-- These are particularly common when talking about monomorphic containers. /e.g./ +-- +-- @ +-- 'sets' Data.Text.map :: 'Setter'' 'Data.Text.Internal.Text' 'Char' +-- @ +-- +-- @ +-- type 'Setter'' = 'Simple' 'Setter' +-- @ +type Setter' s a = Setter s s a a + +-- | Every 'IndexedSetter' is a valid 'Setter'. +-- +-- The 'Setter' laws are still required to hold. +type IndexedSetter i s t a b = forall f p. + (Indexable i p, Settable f) => p a (f b) -> s -> f t + +-- | @ +-- type 'IndexedSetter'' i = 'Simple' ('IndexedSetter' i) +-- @ +type IndexedSetter' i s a = IndexedSetter i s s a a + +-- | An 'IndexPreservingSetter' can be composed with a 'IndexedSetter', 'IndexedTraversal' or 'IndexedLens' +-- and leaves the index intact, yielding an 'IndexedSetter'. +type IndexPreservingSetter s t a b = forall p f. (Conjoined p, Settable f) => p a (f b) -> p s (f t) + +-- | @ +-- type 'IndexedPreservingSetter'' i = 'Simple' 'IndexedPreservingSetter' +-- @ +type IndexPreservingSetter' s a = IndexPreservingSetter s s a a + +----------------------------------------------------------------------------- +-- Isomorphisms +----------------------------------------------------------------------------- + +-- | Isomorphism families can be composed with another 'Lens' using ('.') and 'id'. +-- +-- Since every 'Iso' is both a valid 'Lens' and a valid 'Prism', the laws for those types +-- imply the following laws for an 'Iso' 'f': +-- +-- @ +-- f '.' 'Control.Lens.Iso.from' f ≡ 'id' +-- 'Control.Lens.Iso.from' f '.' f ≡ 'id' +-- @ +-- +-- Note: Composition with an 'Iso' is index- and measure- preserving. +type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) + +-- | @ +-- type 'Iso'' = 'Control.Lens.Type.Simple' 'Iso' +-- @ +type Iso' s a = Iso s s a a + +------------------------------------------------------------------------------ +-- Review Internals +------------------------------------------------------------------------------ + +-- | This is a limited form of a 'Prism' that can only be used for 're' operations. +-- +-- Like with a 'Getter', there are no laws to state for a 'Review'. +-- +-- You can generate a 'Review' by using 'unto'. You can also use any 'Prism' or 'Iso' +-- directly as a 'Review'. +type Review t b = forall p f. (Choice p, Bifunctor p, Settable f) => Optic' p f t b + +-- | If you see this in a signature for a function, the function is expecting a 'Review' +-- (in practice, this usually means a 'Prism'). +type AReview t b = Optic' Tagged Identity t b + +------------------------------------------------------------------------------ +-- Prism Internals +------------------------------------------------------------------------------ + +-- | A 'Prism' @l@ is a 'Traversal' that can also be turned +-- around with 'Control.Lens.Review.re' to obtain a 'Getter' in the +-- opposite direction. +-- +-- There are three laws that a 'Prism' should satisfy: +-- +-- First, if I 'Control.Lens.Review.re' or 'Control.Lens.Review.review' a value with a 'Prism' and then 'Control.Lens.Fold.preview' or use ('Control.Lens.Fold.^?'), I will get it back: +-- +-- @ +-- 'Control.Lens.Fold.preview' l ('Control.Lens.Review.review' l b) ≡ 'Just' b +-- @ +-- +-- Second, if you can extract a value @a@ using a 'Prism' @l@ from a value @s@, then the value @s@ is completely described by @l@ and @a@: +-- +-- @ +-- 'Control.Lens.Fold.preview' l s ≡ 'Just' a ⟹ 'Control.Lens.Review.review' l a ≡ s +-- @ +-- +-- Third, if you get non-match @t@, you can convert it result back to @s@: +-- +-- @ +-- 'Control.Lens.Combinators.matching' l s ≡ 'Left' t ⟹ 'Control.Lens.Combinators.matching' l t ≡ 'Left' s +-- @ +-- +-- The first two laws imply that the 'Traversal' laws hold for every 'Prism' and that we 'Data.Traversable.traverse' at most 1 element: +-- +-- @ +-- 'Control.Lens.Fold.lengthOf' l x '<=' 1 +-- @ +-- +-- It may help to think of this as an 'Iso' that can be partial in one direction. +-- +-- Every 'Prism' is a valid 'Traversal'. +-- +-- Every 'Iso' is a valid 'Prism'. +-- +-- For example, you might have a @'Prism'' 'Integer' 'Numeric.Natural.Natural'@ allows you to always +-- go from a 'Numeric.Natural.Natural' to an 'Integer', and provide you with tools to check if an 'Integer' is +-- a 'Numeric.Natural.Natural' and/or to edit one if it is. +-- +-- +-- @ +-- 'nat' :: 'Prism'' 'Integer' 'Numeric.Natural.Natural' +-- 'nat' = 'Control.Lens.Prism.prism' 'toInteger' '$' \\ i -> +-- if i '<' 0 +-- then 'Left' i +-- else 'Right' ('fromInteger' i) +-- @ +-- +-- Now we can ask if an 'Integer' is a 'Numeric.Natural.Natural'. +-- +-- >>> 5^?nat +-- Just 5 +-- +-- >>> (-5)^?nat +-- Nothing +-- +-- We can update the ones that are: +-- +-- >>> (-3,4) & both.nat *~ 2 +-- (-3,8) +-- +-- And we can then convert from a 'Numeric.Natural.Natural' to an 'Integer'. +-- +-- >>> 5 ^. re nat -- :: Natural +-- 5 +-- +-- Similarly we can use a 'Prism' to 'Data.Traversable.traverse' the 'Left' half of an 'Either': +-- +-- >>> Left "hello" & _Left %~ length +-- Left 5 +-- +-- or to construct an 'Either': +-- +-- >>> 5^.re _Left +-- Left 5 +-- +-- such that if you query it with the 'Prism', you will get your original input back. +-- +-- >>> 5^.re _Left ^? _Left +-- Just 5 +-- +-- Another interesting way to think of a 'Prism' is as the categorical dual of a 'Lens' +-- -- a co-'Lens', so to speak. This is what permits the construction of 'Control.Lens.Prism.outside'. +-- +-- Note: Composition with a 'Prism' is index-preserving. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) + +-- | A 'Simple' 'Prism'. +type Prism' s a = Prism s s a a + +------------------------------------------------------------------------------- +-- Equality +------------------------------------------------------------------------------- + +-- | A witness that @(a ~ s, b ~ t)@. +-- +-- Note: Composition with an 'Equality' is index-preserving. +type Equality (s :: k1) (t :: k2) (a :: k1) (b :: k2) = forall k3 (p :: k1 -> k3 -> Type) (f :: k2 -> k3) . + p a (f b) -> p s (f t) + +-- | A 'Simple' 'Equality'. +type Equality' s a = Equality s s a a + +-- | Composable `asTypeOf`. Useful for constraining excess +-- polymorphism, @foo . (id :: As Int) . bar@. +type As a = Equality' a a + +------------------------------------------------------------------------------- +-- Getters +------------------------------------------------------------------------------- + +-- | A 'Getter' describes how to retrieve a single value in a way that can be +-- composed with other 'LensLike' constructions. +-- +-- Unlike a 'Lens' a 'Getter' is read-only. Since a 'Getter' +-- cannot be used to write back there are no 'Lens' laws that can be applied to +-- it. In fact, it is isomorphic to an arbitrary function from @(s -> a)@. +-- +-- Moreover, a 'Getter' can be used directly as a 'Control.Lens.Fold.Fold', +-- since it just ignores the 'Applicative'. +type Getter s a = forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s + +-- | Every 'IndexedGetter' is a valid 'Control.Lens.Fold.IndexedFold' and can be used for 'Control.Lens.Getter.Getting' like a 'Getter'. +type IndexedGetter i s a = forall p f. (Indexable i p, Contravariant f, Functor f) => p a (f a) -> s -> f s + +-- | An 'IndexPreservingGetter' can be used as a 'Getter', but when composed with an 'IndexedTraversal', +-- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold', 'IndexedFold' or 'IndexedGetter' respectively. +type IndexPreservingGetter s a = forall p f. (Conjoined p, Contravariant f, Functor f) => p a (f a) -> p s (f s) + +-------------------------- +-- Folds +-------------------------- + +-- | A 'Fold' describes how to retrieve multiple values in a way that can be composed +-- with other 'LensLike' constructions. +-- +-- A @'Fold' s a@ provides a structure with operations very similar to those of the 'Data.Foldable.Foldable' +-- typeclass, see 'Control.Lens.Fold.foldMapOf' and the other 'Fold' combinators. +-- +-- By convention, if there exists a 'foo' method that expects a @'Data.Foldable.Foldable' (f a)@, then there should be a +-- @fooOf@ method that takes a @'Fold' s a@ and a value of type @s@. +-- +-- A 'Getter' is a legal 'Fold' that just ignores the supplied 'Data.Monoid.Monoid'. +-- +-- Unlike a 'Control.Lens.Traversal.Traversal' a 'Fold' is read-only. Since a 'Fold' cannot be used to write back +-- there are no 'Lens' laws that apply. +type Fold s a = forall f. (Contravariant f, Applicative f) => (a -> f a) -> s -> f s + +-- | Every 'IndexedFold' is a valid 'Control.Lens.Fold.Fold' and can be used for 'Control.Lens.Getter.Getting'. +type IndexedFold i s a = forall p f. (Indexable i p, Contravariant f, Applicative f) => p a (f a) -> s -> f s + +-- | An 'IndexPreservingFold' can be used as a 'Fold', but when composed with an 'IndexedTraversal', +-- 'IndexedFold', or 'IndexedLens' yields an 'IndexedFold' respectively. +type IndexPreservingFold s a = forall p f. (Conjoined p, Contravariant f, Applicative f) => p a (f a) -> p s (f s) + +-- | A relevant Fold (aka 'Fold1') has one or more targets. +type Fold1 s a = forall f. (Contravariant f, Apply f) => (a -> f a) -> s -> f s +type IndexedFold1 i s a = forall p f. (Indexable i p, Contravariant f, Apply f) => p a (f a) -> s -> f s +type IndexPreservingFold1 s a = forall p f. (Conjoined p, Contravariant f, Apply f) => p a (f a) -> p s (f s) + +------------------------------------------------------------------------------- +-- Simple Overloading +------------------------------------------------------------------------------- + +-- | A 'Simple' 'Lens', 'Simple' 'Traversal', ... can +-- be used instead of a 'Lens','Traversal', ... +-- whenever the type variables don't change upon setting a value. +-- +-- @ +-- 'Data.Complex.Lens._imagPart' :: 'Simple' 'Lens' ('Data.Complex.Complex' a) a +-- 'Control.Lens.Traversal.traversed' :: 'Simple' ('IndexedTraversal' 'Int') [a] a +-- @ +-- +-- Note: To use this alias in your own code with @'LensLike' f@ or +-- 'Setter', you may have to turn on @LiberalTypeSynonyms@. +-- +-- This is commonly abbreviated as a \"prime\" marker, /e.g./ 'Lens'' = 'Simple' 'Lens'. +type Simple f s a = f s s a a + +------------------------------------------------------------------------------- +-- Optics +------------------------------------------------------------------------------- + +-- | A valid 'Optic' @l@ should satisfy the laws: +-- +-- @ +-- l 'pure' ≡ 'pure' +-- l ('Procompose' f g) = 'Procompose' (l f) (l g) +-- @ +-- +-- This gives rise to the laws for 'Equality', 'Iso', 'Prism', 'Lens', +-- 'Traversal', 'Traversal1', 'Setter', 'Fold', 'Fold1', and 'Getter' as well +-- along with their index-preserving variants. +-- +-- @ +-- type 'LensLike' f s t a b = 'Optic' (->) f s t a b +-- @ +type Optic p f s t a b = p a (f b) -> p s (f t) + +-- | @ +-- type 'Optic'' p f s a = 'Simple' ('Optic' p f) s a +-- @ +type Optic' p f s a = Optic p f s s a a + +-- | @ +-- type 'LensLike' f s t a b = 'Optical' (->) (->) f s t a b +-- @ +-- +-- @ +-- type 'Over' p f s t a b = 'Optical' p (->) f s t a b +-- @ +-- +-- @ +-- type 'Optic' p f s t a b = 'Optical' p p f s t a b +-- @ +type Optical p q f s t a b = p a (f b) -> q s (f t) + +-- | @ +-- type 'Optical'' p q f s a = 'Simple' ('Optical' p q f) s a +-- @ +type Optical' p q f s a = Optical p q f s s a a + + +-- | Many combinators that accept a 'Lens' can also accept a +-- 'Traversal' in limited situations. +-- +-- They do so by specializing the type of 'Functor' that they require of the +-- caller. +-- +-- If a function accepts a @'LensLike' f s t a b@ for some 'Functor' @f@, +-- then they may be passed a 'Lens'. +-- +-- Further, if @f@ is an 'Applicative', they may also be passed a +-- 'Traversal'. +type LensLike f s t a b = (a -> f b) -> s -> f t + +-- | @ +-- type 'LensLike'' f = 'Simple' ('LensLike' f) +-- @ +type LensLike' f s a = LensLike f s s a a + +-- | Convenient alias for constructing indexed lenses and their ilk. +type IndexedLensLike i f s t a b = forall p. Indexable i p => p a (f b) -> s -> f t + +-- | Convenient alias for constructing simple indexed lenses and their ilk. +type IndexedLensLike' i f s a = IndexedLensLike i f s s a a + +-- | This is a convenient alias for use when you need to consume either indexed or non-indexed lens-likes based on context. +type Over p f s t a b = p a (f b) -> s -> f t + +-- | This is a convenient alias for use when you need to consume either indexed or non-indexed lens-likes based on context. +-- +-- @ +-- type 'Over'' p f = 'Simple' ('Over' p f) +-- @ +type Over' p f s a = Over p f s s a a + + +-------------------------- +-- Folds +-------------------------- + +-- | Obtain a 'Fold' by lifting an operation that returns a 'Foldable' result. +-- +-- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. +-- +-- >>> [1,2,3,4]^..folding tail +-- [2,3,4] +folding :: Foldable f => (s -> f a) -> Fold s a +folding sfa agb = phantom . traverse_ agb . sfa +{-# INLINE folding #-} + +ifolding :: (Foldable f, Indexable i p, Contravariant g, Applicative g) => (s -> f (i, a)) -> Over p g s t a b +ifolding sfa f = phantom . traverse_ (phantom . uncurry (indexed f)) . sfa +{-# INLINE ifolding #-} + +-- | Obtain a 'Fold' by lifting 'foldr' like function. +-- +-- >>> [1,2,3,4]^..foldring foldr +-- [1,2,3,4] +foldring :: (Contravariant f, Applicative f) => ((a -> f a -> f a) -> f a -> s -> f a) -> LensLike f s t a b +foldring fr f = phantom . fr (\a fa -> f a *> fa) noEffect +{-# INLINE foldring #-} + +-- | Obtain 'FoldWithIndex' by lifting 'ifoldr' like function. +ifoldring :: (Indexable i p, Contravariant f, Applicative f) => ((i -> a -> f a -> f a) -> f a -> s -> f a) -> Over p f s t a b +ifoldring ifr f = phantom . ifr (\i a fa -> indexed f i a *> fa) noEffect +{-# INLINE ifoldring #-} + +-- | Obtain a 'Fold' from any 'Foldable' indexed by ordinal position. +-- +-- >>> Just 3^..folded +-- [3] +-- +-- >>> Nothing^..folded +-- [] +-- +-- >>> [(1,2),(3,4)]^..folded.both +-- [1,2,3,4] +folded :: Foldable f => IndexedFold Int (f a) a +folded = conjoined (foldring foldr) (ifoldring ifoldr) +{-# INLINE folded #-} + +ifoldr :: Foldable f => (Int -> a -> b -> b) -> b -> f a -> b +ifoldr f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 +{-# INLINE ifoldr #-} + +-- | Obtain a 'Fold' from any 'Foldable' indexed by ordinal position. +folded64 :: Foldable f => IndexedFold Int64 (f a) a +folded64 = conjoined (foldring foldr) (ifoldring ifoldr64) +{-# INLINE folded64 #-} + +ifoldr64 :: Foldable f => (Int64 -> a -> b -> b) -> b -> f a -> b +ifoldr64 f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0 +{-# INLINE ifoldr64 #-} + +-- | Form a 'Fold1' by repeating the input forever. +-- +-- @ +-- 'repeat' ≡ 'toListOf' 'repeated' +-- @ +-- +-- >>> timingOut $ 5^..taking 20 repeated +-- [5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5] +-- +-- @ +-- 'repeated' :: 'Fold1' a a +-- @ +repeated :: Apply f => LensLike' f a a +repeated f a = as where as = f a .> as +{-# INLINE repeated #-} + +-- | A 'Fold' that replicates its input @n@ times. +-- +-- @ +-- 'replicate' n ≡ 'toListOf' ('replicated' n) +-- @ +-- +-- >>> 5^..replicated 20 +-- [5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5] +replicated :: Int -> Fold a a +replicated n0 f a = go n0 where + m = f a + go 0 = noEffect + go n = m *> go (n - 1) +{-# INLINE replicated #-} + +-- | Transform a non-empty 'Fold' into a 'Fold1' that loops over its elements over and over. +-- +-- >>> timingOut $ [1,2,3]^..taking 7 (cycled traverse) +-- [1,2,3,1,2,3,1] +-- +-- @ +-- 'cycled' :: 'Fold1' s a -> 'Fold1' s a +-- @ +cycled :: Apply f => LensLike f s t a b -> LensLike f s t a b +cycled l f a = as where as = l f a .> as +{-# INLINE cycled #-} + +-- | Build a 'Fold' that unfolds its values from a seed. +-- +-- @ +-- 'Prelude.unfoldr' ≡ 'toListOf' '.' 'unfolded' +-- @ +-- +-- >>> 10^..unfolded (\b -> if b == 0 then Nothing else Just (b, b-1)) +-- [10,9,8,7,6,5,4,3,2,1] +unfolded :: (b -> Maybe (a, b)) -> Fold b a +unfolded f g = go where + go b = case f b of + Just (a, b') -> g a *> go b' + Nothing -> noEffect +{-# INLINE unfolded #-} + +-- | @x '^.' 'iterated' f@ returns an infinite 'Fold1' of repeated applications of @f@ to @x@. +-- +-- @ +-- 'toListOf' ('iterated' f) a ≡ 'iterate' f a +-- @ +-- +-- @ +-- 'iterated' :: (a -> a) -> 'Fold1' a a +-- @ +iterated :: Apply f => (a -> a) -> LensLike' f a a +iterated f g = go where + go a = g a .> go (f a) +{-# INLINE iterated #-} + +-- | Obtain a 'Fold' that can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). +-- +-- Note: This is /not/ a legal 'Traversal', unless you are very careful not to invalidate the predicate on the target. +-- +-- Note: This is also /not/ a legal 'Prism', unless you are very careful not to inject a value that fails the predicate. +-- +-- As a counter example, consider that given @evens = 'filtered' 'even'@ the second 'Traversal' law is violated: +-- +-- @ +-- 'Control.Lens.Setter.over' evens 'succ' '.' 'Control.Lens.Setter.over' evens 'succ' '/=' 'Control.Lens.Setter.over' evens ('succ' '.' 'succ') +-- @ +-- +-- So, in order for this to qualify as a legal 'Traversal' you can only use it for actions that preserve the result of the predicate! +-- +-- >>> [1..10]^..folded.filtered even +-- [2,4,6,8,10] +-- +-- This will preserve an index if it is present. +filtered :: (Choice p, Applicative f) => (a -> Bool) -> Optic' p f a a +filtered p = dimap (\x -> if p x then Right x else Left x) (either pure id) . right' +{-# INLINE filtered #-} + +-- | Obtain a potentially empty 'IndexedTraversal' by taking the first element from another, +-- potentially empty `Fold` and using it as an index. +-- +-- The resulting optic can be composed with to filter another 'Lens', 'Iso', 'Getter', 'Fold' (or 'Traversal'). +-- +-- >>> [(Just 2, 3), (Nothing, 4)] & mapped . filteredBy (_1 . _Just) <. _2 %@~ (*) :: [(Maybe Int, Int)] +-- [(Just 2,6),(Nothing,4)] +-- +-- @ +-- 'filteredBy' :: 'Fold' a i -> 'IndexedTraversal'' i a a +-- @ +-- +-- Note: As with 'filtered', this is /not/ a legal 'IndexedTraversal', unless you are very careful not to invalidate the predicate on the target! +filteredBy :: (Indexable i p, Applicative f) => Getting (First i) a i -> p a (f a) -> a -> f a +filteredBy p f val = case val ^? p of + Nothing -> pure val + Just witness -> indexed f witness val + +-- | Obtain a 'Fold' by taking elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. +-- +-- @ +-- 'takeWhile' p ≡ 'toListOf' ('takingWhile' p 'folded') +-- @ +-- +-- >>> timingOut $ toListOf (takingWhile (<=3) folded) [1..] +-- [1,2,3] +-- +-- @ +-- 'takingWhile' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s a +-- 'takingWhile' :: (a -> 'Bool') -> 'Getter' s a -> 'Fold' s a +-- 'takingWhile' :: (a -> 'Bool') -> 'Traversal'' s a -> 'Fold' s a -- * See note below +-- 'takingWhile' :: (a -> 'Bool') -> 'Lens'' s a -> 'Fold' s a -- * See note below +-- 'takingWhile' :: (a -> 'Bool') -> 'Prism'' s a -> 'Fold' s a -- * See note below +-- 'takingWhile' :: (a -> 'Bool') -> 'Iso'' s a -> 'Fold' s a -- * See note below +-- 'takingWhile' :: (a -> 'Bool') -> 'IndexedTraversal'' i s a -> 'IndexedFold' i s a -- * See note below +-- 'takingWhile' :: (a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- * See note below +-- 'takingWhile' :: (a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a +-- 'takingWhile' :: (a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a +-- @ +-- +-- /Note:/ When applied to a 'Traversal', 'takingWhile' yields something that can be used as if it were a 'Traversal', but +-- which is not a 'Traversal' per the laws, unless you are careful to ensure that you do not invalidate the predicate when +-- writing back through it. +takingWhile :: (Conjoined p, Applicative f) => (a -> Bool) -> Over p (TakingWhile p f a a) s t a a -> Over p f s t a a +takingWhile p l pafb = fmap runMagma . traverse (cosieve pafb) . runTakingWhile . l flag where + flag = cotabulate $ \wa -> let a = extract wa; r = p a in TakingWhile r a $ \pr -> + if pr && r then Magma () wa else MagmaPure a +{-# INLINE takingWhile #-} + +-- | Obtain a 'Fold' by dropping elements from another 'Fold', 'Lens', 'Iso', 'Getter' or 'Traversal' while a predicate holds. +-- +-- @ +-- 'dropWhile' p ≡ 'toListOf' ('droppingWhile' p 'folded') +-- @ +-- +-- >>> toListOf (droppingWhile (<=3) folded) [1..6] +-- [4,5,6] +-- +-- >>> toListOf (droppingWhile (<=3) folded) [1,6,1] +-- [6,1] +-- +-- @ +-- 'droppingWhile' :: (a -> 'Bool') -> 'Fold' s a -> 'Fold' s a +-- 'droppingWhile' :: (a -> 'Bool') -> 'Getter' s a -> 'Fold' s a +-- 'droppingWhile' :: (a -> 'Bool') -> 'Traversal'' s a -> 'Fold' s a -- see notes +-- 'droppingWhile' :: (a -> 'Bool') -> 'Lens'' s a -> 'Fold' s a -- see notes +-- 'droppingWhile' :: (a -> 'Bool') -> 'Prism'' s a -> 'Fold' s a -- see notes +-- 'droppingWhile' :: (a -> 'Bool') -> 'Iso'' s a -> 'Fold' s a -- see notes +-- @ +-- +-- @ +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingTraversal'' s a -> 'IndexPreservingFold' s a -- see notes +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingLens'' s a -> 'IndexPreservingFold' s a -- see notes +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingGetter' s a -> 'IndexPreservingFold' s a +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexPreservingFold' s a -> 'IndexPreservingFold' s a +-- @ +-- +-- @ +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedTraversal'' i s a -> 'IndexedFold' i s a -- see notes +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- see notes +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a +-- 'droppingWhile' :: (a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a +-- @ +-- +-- Note: Many uses of this combinator will yield something that meets the types, but not the laws of a valid +-- 'Traversal' or 'IndexedTraversal'. The 'Traversal' and 'IndexedTraversal' laws are only satisfied if the +-- new values you assign to the first target also does not pass the predicate! Otherwise subsequent traversals +-- will visit fewer elements and 'Traversal' fusion is not sound. +-- +-- So for any traversal @t@ and predicate @p@, @`droppingWhile` p t@ may not be lawful, but +-- @(`Control.Lens.Traversal.dropping` 1 . `droppingWhile` p) t@ is. For example: +-- +-- >>> let l :: Traversal' [Int] Int; l = droppingWhile (<= 1) traverse +-- >>> let l' :: Traversal' [Int] Int; l' = dropping 1 l +-- +-- @l@ is not a lawful setter because @`Control.Lens.Setter.over` l f . +-- `Control.Lens.Setter.over` l g ≢ `Control.Lens.Setter.over` l (f . g)@: +-- +-- >>> [1,2,3] & l .~ 0 & l .~ 4 +-- [1,0,0] +-- >>> [1,2,3] & l .~ 4 +-- [1,4,4] +-- +-- @l'@ on the other hand behaves lawfully: +-- +-- >>> [1,2,3] & l' .~ 0 & l' .~ 4 +-- [1,2,4] +-- >>> [1,2,3] & l' .~ 4 +-- [1,2,4] +droppingWhile :: (Conjoined p, Profunctor q, Applicative f) + => (a -> Bool) + -> Optical p q (Compose (State Bool) f) s t a a + -> Optical p q f s t a a +droppingWhile p l f = (flip evalState True .# getCompose) `rmap` l g where + g = cotabulate $ \wa -> Compose $ state $ \b -> let + a = extract wa + b' = b && p a + in (if b' then pure a else cosieve f wa, b') +{-# INLINE droppingWhile #-} + +-- | A 'Fold' over the individual 'words' of a 'String'. +-- +-- @ +-- 'worded' :: 'Fold' 'String' 'String' +-- 'worded' :: 'Traversal'' 'String' 'String' +-- @ +-- +-- @ +-- 'worded' :: 'IndexedFold' 'Int' 'String' 'String' +-- 'worded' :: 'IndexedTraversal'' 'Int' 'String' 'String' +-- @ +-- +-- Note: This function type-checks as a 'Traversal' but it doesn't satisfy the laws. It's only valid to use it +-- when you don't insert any whitespace characters while traversing, and if your original 'String' contains only +-- isolated space characters (and no other characters that count as space, such as non-breaking spaces). +worded :: Applicative f => IndexedLensLike' Int f String String +worded f = fmap unwords . conjoined traverse (indexing traverse) f . words +{-# INLINE worded #-} + +-- | A 'Fold' over the individual 'lines' of a 'String'. +-- +-- @ +-- 'lined' :: 'Fold' 'String' 'String' +-- 'lined' :: 'Traversal'' 'String' 'String' +-- @ +-- +-- @ +-- 'lined' :: 'IndexedFold' 'Int' 'String' 'String' +-- 'lined' :: 'IndexedTraversal'' 'Int' 'String' 'String' +-- @ +-- +-- Note: This function type-checks as a 'Traversal' but it doesn't satisfy the laws. It's only valid to use it +-- when you don't insert any newline characters while traversing, and if your original 'String' contains only +-- isolated newline characters. +lined :: Applicative f => IndexedLensLike' Int f String String +lined f = fmap (intercalate "\n") . conjoined traverse (indexing traverse) f . lines +{-# INLINE lined #-} + +-------------------------- +-- Fold/Getter combinators +-------------------------- + +-- | Map each part of a structure viewed through a 'Lens', 'Getter', +-- 'Fold' or 'Traversal' to a monoid and combine the results. +-- +-- >>> foldMapOf (folded . both . _Just) Sum [(Just 21, Just 21)] +-- Sum {getSum = 42} +-- +-- @ +-- 'Data.Foldable.foldMap' = 'foldMapOf' 'folded' +-- @ +-- +-- @ +-- 'foldMapOf' ≡ 'views' +-- 'ifoldMapOf' l = 'foldMapOf' l '.' 'Indexed' +-- @ +-- +-- @ +-- 'foldMapOf' :: 'Getter' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Semigroup' r => 'Fold1' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Lens'' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Iso'' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Monoid' r => 'Traversal'' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Semigroup' r => 'Traversal1'' s a -> (a -> r) -> s -> r +-- 'foldMapOf' :: 'Monoid' r => 'Prism'' s a -> (a -> r) -> s -> r +-- @ +-- +-- @ +-- 'foldMapOf' :: 'Getting' r s a -> (a -> r) -> s -> r +-- @ +foldMapOf :: Getting r s a -> (a -> r) -> s -> r +foldMapOf = coerce +{-# INLINE foldMapOf #-} + +-- | Combine the elements of a structure viewed through a 'Lens', 'Getter', +-- 'Fold' or 'Traversal' using a monoid. +-- +-- >>> foldOf (folded.folded) [[Sum 1,Sum 4],[Sum 8, Sum 8],[Sum 21]] +-- Sum {getSum = 42} +-- +-- @ +-- 'Data.Foldable.fold' = 'foldOf' 'folded' +-- @ +-- +-- @ +-- 'foldOf' ≡ 'view' +-- @ +-- +-- @ +-- 'foldOf' :: 'Getter' s m -> s -> m +-- 'foldOf' :: 'Monoid' m => 'Fold' s m -> s -> m +-- 'foldOf' :: 'Lens'' s m -> s -> m +-- 'foldOf' :: 'Iso'' s m -> s -> m +-- 'foldOf' :: 'Monoid' m => 'Traversal'' s m -> s -> m +-- 'foldOf' :: 'Monoid' m => 'Prism'' s m -> s -> m +-- @ +foldOf :: Getting a s a -> s -> a +foldOf l = getConst #. l Const +{-# INLINE foldOf #-} + +-- | Right-associative fold of parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. +-- +-- @ +-- 'Data.Foldable.foldr' ≡ 'foldrOf' 'folded' +-- @ +-- +-- @ +-- 'foldrOf' :: 'Getter' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf' :: 'Fold' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf' :: 'Lens'' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf' :: 'Iso'' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf' :: 'Prism'' s a -> (a -> r -> r) -> r -> s -> r +-- @ +-- +-- @ +-- 'ifoldrOf' l ≡ 'foldrOf' l '.' 'Indexed' +-- @ +-- +-- @ +-- 'foldrOf' :: 'Getting' ('Endo' r) s a -> (a -> r -> r) -> r -> s -> r +-- @ +foldrOf :: Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r +foldrOf l f z = flip appEndo z . foldMapOf l (Endo #. f) +{-# INLINE foldrOf #-} + +-- | Left-associative fold of the parts of a structure that are viewed through a 'Lens', 'Getter', 'Fold' or 'Traversal'. +-- +-- @ +-- 'Data.Foldable.foldl' ≡ 'foldlOf' 'folded' +-- @ +-- +-- @ +-- 'foldlOf' :: 'Getter' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf' :: 'Fold' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf' :: 'Lens'' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf' :: 'Iso'' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf' :: 'Prism'' s a -> (r -> a -> r) -> r -> s -> r +-- @ +foldlOf :: Getting (Dual (Endo r)) s a -> (r -> a -> r) -> r -> s -> r +foldlOf l f z = (flip appEndo z .# getDual) `rmap` foldMapOf l (Dual #. Endo #. flip f) +{-# INLINE foldlOf #-} + +-- | Extract a list of the targets of a 'Fold'. See also ('^..'). +-- +-- @ +-- 'Data.Foldable.toList' ≡ 'toListOf' 'folded' +-- ('^..') ≡ 'flip' 'toListOf' +-- @ + +-- >>> toListOf both ("hello","world") +-- ["hello","world"] +-- +-- @ +-- 'toListOf' :: 'Getter' s a -> s -> [a] +-- 'toListOf' :: 'Fold' s a -> s -> [a] +-- 'toListOf' :: 'Lens'' s a -> s -> [a] +-- 'toListOf' :: 'Iso'' s a -> s -> [a] +-- 'toListOf' :: 'Traversal'' s a -> s -> [a] +-- 'toListOf' :: 'Prism'' s a -> s -> [a] +-- @ +toListOf :: Getting (Endo [a]) s a -> s -> [a] +toListOf l = foldrOf l (:) [] +{-# INLINE toListOf #-} + +-- | Extract a 'NonEmpty' of the targets of 'Fold1'. +-- +-- >>> toNonEmptyOf both1 ("hello", "world") +-- "hello" :| ["world"] +-- +-- @ +-- 'toNonEmptyOf' :: 'Getter' s a -> s -> NonEmpty a +-- 'toNonEmptyOf' :: 'Fold1' s a -> s -> NonEmpty a +-- 'toNonEmptyOf' :: 'Lens'' s a -> s -> NonEmpty a +-- 'toNonEmptyOf' :: 'Iso'' s a -> s -> NonEmpty a +-- 'toNonEmptyOf' :: 'Traversal1'' s a -> s -> NonEmpty a +-- 'toNonEmptyOf' :: 'Prism'' s a -> s -> NonEmpty a +-- @ +toNonEmptyOf :: Getting (NonEmptyDList a) s a -> s -> NonEmpty a +toNonEmptyOf l = flip getNonEmptyDList [] . foldMapOf l (NonEmptyDList #. (:|)) + +-- | A convenient infix (flipped) version of 'toListOf'. +-- +-- >>> [[1,2],[3]]^..id +-- [[[1,2],[3]]] +-- >>> [[1,2],[3]]^..traverse +-- [[1,2],[3]] +-- >>> [[1,2],[3]]^..traverse.traverse +-- [1,2,3] +-- +-- >>> (1,2)^..both +-- [1,2] +-- +-- @ +-- 'Data.Foldable.toList' xs ≡ xs '^..' 'folded' +-- ('^..') ≡ 'flip' 'toListOf' +-- @ +-- +-- @ +-- ('^..') :: s -> 'Getter' s a -> [a] +-- ('^..') :: s -> 'Fold' s a -> [a] +-- ('^..') :: s -> 'Lens'' s a -> [a] +-- ('^..') :: s -> 'Iso'' s a -> [a] +-- ('^..') :: s -> 'Traversal'' s a -> [a] +-- ('^..') :: s -> 'Prism'' s a -> [a] +-- @ +(^..) :: s -> Getting (Endo [a]) s a -> [a] +s ^.. l = toListOf l s +{-# INLINE (^..) #-} + +-- | Returns 'True' if every target of a 'Fold' is 'True'. +-- +-- >>> andOf both (True,False) +-- False +-- >>> andOf both (True,True) +-- True +-- +-- @ +-- 'Data.Foldable.and' ≡ 'andOf' 'folded' +-- @ +-- +-- @ +-- 'andOf' :: 'Getter' s 'Bool' -> s -> 'Bool' +-- 'andOf' :: 'Fold' s 'Bool' -> s -> 'Bool' +-- 'andOf' :: 'Lens'' s 'Bool' -> s -> 'Bool' +-- 'andOf' :: 'Iso'' s 'Bool' -> s -> 'Bool' +-- 'andOf' :: 'Traversal'' s 'Bool' -> s -> 'Bool' +-- 'andOf' :: 'Prism'' s 'Bool' -> s -> 'Bool' +-- @ +andOf :: Getting All s Bool -> s -> Bool +andOf l = getAll #. foldMapOf l All +{-# INLINE andOf #-} + +-- | Returns 'True' if any target of a 'Fold' is 'True'. +-- +-- >>> orOf both (True,False) +-- True +-- >>> orOf both (False,False) +-- False +-- +-- @ +-- 'Data.Foldable.or' ≡ 'orOf' 'folded' +-- @ +-- +-- @ +-- 'orOf' :: 'Getter' s 'Bool' -> s -> 'Bool' +-- 'orOf' :: 'Fold' s 'Bool' -> s -> 'Bool' +-- 'orOf' :: 'Lens'' s 'Bool' -> s -> 'Bool' +-- 'orOf' :: 'Iso'' s 'Bool' -> s -> 'Bool' +-- 'orOf' :: 'Traversal'' s 'Bool' -> s -> 'Bool' +-- 'orOf' :: 'Prism'' s 'Bool' -> s -> 'Bool' +-- @ +orOf :: Getting Any s Bool -> s -> Bool +orOf l = getAny #. foldMapOf l Any +{-# INLINE orOf #-} + +-- | Returns 'True' if any target of a 'Fold' satisfies a predicate. +-- +-- >>> anyOf both (=='x') ('x','y') +-- True +-- >>> import Data.Data.Lens +-- >>> anyOf biplate (== "world") (((),2::Int),"hello",("world",11::Int)) +-- True +-- +-- @ +-- 'Data.Foldable.any' ≡ 'anyOf' 'folded' +-- @ +-- +-- @ +-- 'ianyOf' l ≡ 'anyOf' l '.' 'Indexed' +-- @ +-- +-- @ +-- 'anyOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'anyOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'anyOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'anyOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'anyOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'anyOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- @ +anyOf :: Getting Any s a -> (a -> Bool) -> s -> Bool +anyOf l f = getAny #. foldMapOf l (Any #. f) +{-# INLINE anyOf #-} + +-- | Returns 'True' if every target of a 'Fold' satisfies a predicate. +-- +-- >>> allOf both (>=3) (4,5) +-- True +-- >>> allOf folded (>=2) [1..10] +-- False +-- +-- @ +-- 'Data.Foldable.all' ≡ 'allOf' 'folded' +-- @ +-- +-- @ +-- 'iallOf' l = 'allOf' l '.' 'Indexed' +-- @ +-- +-- @ +-- 'allOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'allOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'allOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'allOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'allOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'allOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- @ +allOf :: Getting All s a -> (a -> Bool) -> s -> Bool +allOf l f = getAll #. foldMapOf l (All #. f) +{-# INLINE allOf #-} + +-- | Returns 'True' only if no targets of a 'Fold' satisfy a predicate. +-- +-- >>> noneOf each (is _Nothing) (Just 3, Just 4, Just 5) +-- True +-- >>> noneOf (folded.folded) (<10) [[13,99,20],[3,71,42]] +-- False +-- +-- @ +-- 'inoneOf' l = 'noneOf' l '.' 'Indexed' +-- @ +-- +-- @ +-- 'noneOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'noneOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'noneOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'noneOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'noneOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- 'noneOf' :: 'Prism'' s a -> (a -> 'Bool') -> s -> 'Bool' +-- @ +noneOf :: Getting Any s a -> (a -> Bool) -> s -> Bool +noneOf l f = not . anyOf l f +{-# INLINE noneOf #-} + +-- | Calculate the 'Product' of every number targeted by a 'Fold'. +-- +-- >>> productOf both (4,5) +-- 20 +-- >>> productOf folded [1,2,3,4,5] +-- 120 +-- +-- @ +-- 'Data.Foldable.product' ≡ 'productOf' 'folded' +-- @ +-- +-- This operation may be more strict than you would expect. If you +-- want a lazier version use @'ala' 'Product' '.' 'foldMapOf'@ +-- +-- @ +-- 'productOf' :: 'Num' a => 'Getter' s a -> s -> a +-- 'productOf' :: 'Num' a => 'Fold' s a -> s -> a +-- 'productOf' :: 'Num' a => 'Lens'' s a -> s -> a +-- 'productOf' :: 'Num' a => 'Iso'' s a -> s -> a +-- 'productOf' :: 'Num' a => 'Traversal'' s a -> s -> a +-- 'productOf' :: 'Num' a => 'Prism'' s a -> s -> a +-- @ +productOf :: Num a => Getting (Endo (Endo a)) s a -> s -> a +productOf l = foldlOf' l (*) 1 +{-# INLINE productOf #-} + +-- | Calculate the 'Sum' of every number targeted by a 'Fold'. +-- +-- >>> sumOf both (5,6) +-- 11 +-- >>> sumOf folded [1,2,3,4] +-- 10 +-- >>> sumOf (folded.both) [(1,2),(3,4)] +-- 10 +-- >>> import Data.Data.Lens +-- >>> sumOf biplate [(1::Int,[]),(2,[(3::Int,4::Int)])] :: Int +-- 10 +-- +-- @ +-- 'Data.Foldable.sum' ≡ 'sumOf' 'folded' +-- @ +-- +-- This operation may be more strict than you would expect. If you +-- want a lazier version use @'ala' 'Sum' '.' 'foldMapOf'@ +-- +-- @ +-- 'sumOf' '_1' :: 'Num' a => (a, b) -> a +-- 'sumOf' ('folded' '.' 'Control.Lens.Tuple._1') :: ('Foldable' f, 'Num' a) => f (a, b) -> a +-- @ +-- +-- @ +-- 'sumOf' :: 'Num' a => 'Getter' s a -> s -> a +-- 'sumOf' :: 'Num' a => 'Fold' s a -> s -> a +-- 'sumOf' :: 'Num' a => 'Lens'' s a -> s -> a +-- 'sumOf' :: 'Num' a => 'Iso'' s a -> s -> a +-- 'sumOf' :: 'Num' a => 'Traversal'' s a -> s -> a +-- 'sumOf' :: 'Num' a => 'Prism'' s a -> s -> a +-- @ +sumOf :: Num a => Getting (Endo (Endo a)) s a -> s -> a +sumOf l = foldlOf' l (+) 0 +{-# INLINE sumOf #-} + +-- | Traverse over all of the targets of a 'Fold' (or 'Getter'), computing an 'Applicative' (or 'Functor')-based answer, +-- but unlike 'Control.Lens.Traversal.traverseOf' do not construct a new structure. 'traverseOf_' generalizes +-- 'Data.Foldable.traverse_' to work over any 'Fold'. +-- +-- When passed a 'Getter', 'traverseOf_' can work over any 'Functor', but when passed a 'Fold', 'traverseOf_' requires +-- an 'Applicative'. +-- +-- >>> traverseOf_ both putStrLn ("hello","world") +-- hello +-- world +-- +-- @ +-- 'Data.Foldable.traverse_' ≡ 'traverseOf_' 'folded' +-- @ +-- +-- @ +-- 'traverseOf_' '_2' :: 'Functor' f => (c -> f r) -> (d, c) -> f () +-- 'traverseOf_' 'Control.Lens.Prism._Left' :: 'Applicative' f => (a -> f b) -> 'Either' a c -> f () +-- @ +-- +-- @ +-- 'itraverseOf_' l ≡ 'traverseOf_' l '.' 'Indexed' +-- @ +-- +-- The rather specific signature of 'traverseOf_' allows it to be used as if the signature was any of: +-- +-- @ +-- 'traverseOf_' :: 'Functor' f => 'Getter' s a -> (a -> f r) -> s -> f () +-- 'traverseOf_' :: 'Applicative' f => 'Fold' s a -> (a -> f r) -> s -> f () +-- 'traverseOf_' :: 'Functor' f => 'Lens'' s a -> (a -> f r) -> s -> f () +-- 'traverseOf_' :: 'Functor' f => 'Iso'' s a -> (a -> f r) -> s -> f () +-- 'traverseOf_' :: 'Applicative' f => 'Traversal'' s a -> (a -> f r) -> s -> f () +-- 'traverseOf_' :: 'Applicative' f => 'Prism'' s a -> (a -> f r) -> s -> f () +-- @ +traverseOf_ :: Functor f => Getting (Traversed r f) s a -> (a -> f r) -> s -> f () +traverseOf_ l f = void . getTraversed #. foldMapOf l (Traversed #. f) +{-# INLINE traverseOf_ #-} + +-- | Traverse over all of the targets of a 'Fold' (or 'Getter'), computing an 'Applicative' (or 'Functor')-based answer, +-- but unlike 'Control.Lens.Traversal.forOf' do not construct a new structure. 'forOf_' generalizes +-- 'Data.Foldable.for_' to work over any 'Fold'. +-- +-- When passed a 'Getter', 'forOf_' can work over any 'Functor', but when passed a 'Fold', 'forOf_' requires +-- an 'Applicative'. +-- +-- @ +-- 'for_' ≡ 'forOf_' 'folded' +-- @ +-- +-- >>> forOf_ both ("hello","world") putStrLn +-- hello +-- world +-- +-- The rather specific signature of 'forOf_' allows it to be used as if the signature was any of: +-- +-- @ +-- 'iforOf_' l s ≡ 'forOf_' l s '.' 'Indexed' +-- @ +-- +-- @ +-- 'forOf_' :: 'Functor' f => 'Getter' s a -> s -> (a -> f r) -> f () +-- 'forOf_' :: 'Applicative' f => 'Fold' s a -> s -> (a -> f r) -> f () +-- 'forOf_' :: 'Functor' f => 'Lens'' s a -> s -> (a -> f r) -> f () +-- 'forOf_' :: 'Functor' f => 'Iso'' s a -> s -> (a -> f r) -> f () +-- 'forOf_' :: 'Applicative' f => 'Traversal'' s a -> s -> (a -> f r) -> f () +-- 'forOf_' :: 'Applicative' f => 'Prism'' s a -> s -> (a -> f r) -> f () +-- @ +forOf_ :: Functor f => Getting (Traversed r f) s a -> s -> (a -> f r) -> f () +forOf_ = flip . traverseOf_ +{-# INLINE forOf_ #-} + +-- | Evaluate each action in observed by a 'Fold' on a structure from left to right, ignoring the results. +-- +-- @ +-- 'sequenceA_' ≡ 'sequenceAOf_' 'folded' +-- @ +-- +-- >>> sequenceAOf_ both (putStrLn "hello",putStrLn "world") +-- hello +-- world +-- +-- @ +-- 'sequenceAOf_' :: 'Functor' f => 'Getter' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Applicative' f => 'Fold' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Functor' f => 'Lens'' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Functor' f => 'Iso'' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Applicative' f => 'Traversal'' s (f a) -> s -> f () +-- 'sequenceAOf_' :: 'Applicative' f => 'Prism'' s (f a) -> s -> f () +-- @ +sequenceAOf_ :: Functor f => Getting (Traversed a f) s (f a) -> s -> f () +sequenceAOf_ l = void . getTraversed #. foldMapOf l Traversed +{-# INLINE sequenceAOf_ #-} + +-- | Traverse over all of the targets of a 'Fold1', computing an 'Apply' based answer. +-- +-- As long as you have 'Applicative' or 'Functor' effect you are better using 'traverseOf_'. +-- The 'traverse1Of_' is useful only when you have genuine 'Apply' effect. +-- +-- >>> traverse1Of_ both1 (\ks -> Map.fromList [ (k, ()) | k <- ks ]) ("abc", "bcd") +-- fromList [('b',()),('c',())] +-- +-- @ +-- 'traverse1Of_' :: 'Apply' f => 'Fold1' s a -> (a -> f r) -> s -> f () +-- @ +-- +-- @since 4.16 +traverse1Of_ :: Functor f => Getting (TraversedF r f) s a -> (a -> f r) -> s -> f () +traverse1Of_ l f = void . getTraversedF #. foldMapOf l (TraversedF #. f) +{-# INLINE traverse1Of_ #-} + +-- | See 'forOf_' and 'traverse1Of_'. +-- +-- >>> for1Of_ both1 ("abc", "bcd") (\ks -> Map.fromList [ (k, ()) | k <- ks ]) +-- fromList [('b',()),('c',())] +-- +-- @ +-- 'for1Of_' :: 'Apply' f => 'Fold1' s a -> s -> (a -> f r) -> f () +-- @ +-- +-- @since 4.16 +for1Of_ :: Functor f => Getting (TraversedF r f) s a -> s -> (a -> f r) -> f () +for1Of_ = flip . traverse1Of_ +{-# INLINE for1Of_ #-} + +-- | See 'sequenceAOf_' and 'traverse1Of_'. +-- +-- @ +-- 'sequence1Of_' :: 'Apply' f => 'Fold1' s (f a) -> s -> f () +-- @ +-- +-- @since 4.16 +sequence1Of_ :: Functor f => Getting (TraversedF a f) s (f a) -> s -> f () +sequence1Of_ l = void . getTraversedF #. foldMapOf l TraversedF +{-# INLINE sequence1Of_ #-} + +-- | Map each target of a 'Fold' on a structure to a monadic action, evaluate these actions from left to right, and ignore the results. +-- +-- >>> mapMOf_ both putStrLn ("hello","world") +-- hello +-- world +-- +-- @ +-- 'Data.Foldable.mapM_' ≡ 'mapMOf_' 'folded' +-- @ +-- +-- @ +-- 'mapMOf_' :: 'Monad' m => 'Getter' s a -> (a -> m r) -> s -> m () +-- 'mapMOf_' :: 'Monad' m => 'Fold' s a -> (a -> m r) -> s -> m () +-- 'mapMOf_' :: 'Monad' m => 'Lens'' s a -> (a -> m r) -> s -> m () +-- 'mapMOf_' :: 'Monad' m => 'Iso'' s a -> (a -> m r) -> s -> m () +-- 'mapMOf_' :: 'Monad' m => 'Traversal'' s a -> (a -> m r) -> s -> m () +-- 'mapMOf_' :: 'Monad' m => 'Prism'' s a -> (a -> m r) -> s -> m () +-- @ +mapMOf_ :: Monad m => Getting (Sequenced r m) s a -> (a -> m r) -> s -> m () +mapMOf_ l f = liftM skip . getSequenced #. foldMapOf l (Sequenced #. f) +{-# INLINE mapMOf_ #-} + +-- | 'forMOf_' is 'mapMOf_' with two of its arguments flipped. +-- +-- >>> forMOf_ both ("hello","world") putStrLn +-- hello +-- world +-- +-- @ +-- 'Data.Foldable.forM_' ≡ 'forMOf_' 'folded' +-- @ +-- +-- @ +-- 'forMOf_' :: 'Monad' m => 'Getter' s a -> s -> (a -> m r) -> m () +-- 'forMOf_' :: 'Monad' m => 'Fold' s a -> s -> (a -> m r) -> m () +-- 'forMOf_' :: 'Monad' m => 'Lens'' s a -> s -> (a -> m r) -> m () +-- 'forMOf_' :: 'Monad' m => 'Iso'' s a -> s -> (a -> m r) -> m () +-- 'forMOf_' :: 'Monad' m => 'Traversal'' s a -> s -> (a -> m r) -> m () +-- 'forMOf_' :: 'Monad' m => 'Prism'' s a -> s -> (a -> m r) -> m () +-- @ +forMOf_ :: Monad m => Getting (Sequenced r m) s a -> s -> (a -> m r) -> m () +forMOf_ = flip . mapMOf_ +{-# INLINE forMOf_ #-} + +-- | Evaluate each monadic action referenced by a 'Fold' on the structure from left to right, and ignore the results. +-- +-- >>> sequenceOf_ both (putStrLn "hello",putStrLn "world") +-- hello +-- world +-- +-- @ +-- 'Data.Foldable.sequence_' ≡ 'sequenceOf_' 'folded' +-- @ +-- +-- @ +-- 'sequenceOf_' :: 'Monad' m => 'Getter' s (m a) -> s -> m () +-- 'sequenceOf_' :: 'Monad' m => 'Fold' s (m a) -> s -> m () +-- 'sequenceOf_' :: 'Monad' m => 'Lens'' s (m a) -> s -> m () +-- 'sequenceOf_' :: 'Monad' m => 'Iso'' s (m a) -> s -> m () +-- 'sequenceOf_' :: 'Monad' m => 'Traversal'' s (m a) -> s -> m () +-- 'sequenceOf_' :: 'Monad' m => 'Prism'' s (m a) -> s -> m () +-- @ +sequenceOf_ :: Monad m => Getting (Sequenced a m) s (m a) -> s -> m () +sequenceOf_ l = liftM skip . getSequenced #. foldMapOf l Sequenced +{-# INLINE sequenceOf_ #-} + +-- | The sum of a collection of actions, generalizing 'concatOf'. +-- +-- >>> asumOf both ("hello","world") +-- "helloworld" +-- +-- >>> asumOf each (Nothing, Just "hello", Nothing) +-- Just "hello" +-- +-- @ +-- 'asum' ≡ 'asumOf' 'folded' +-- @ +-- +-- @ +-- 'asumOf' :: 'Alternative' f => 'Getter' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Fold' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Lens'' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Iso'' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Traversal'' s (f a) -> s -> f a +-- 'asumOf' :: 'Alternative' f => 'Prism'' s (f a) -> s -> f a +-- @ +asumOf :: Alternative f => Getting (Endo (f a)) s (f a) -> s -> f a +asumOf l = foldrOf l (<|>) empty +{-# INLINE asumOf #-} + +-- | The sum of a collection of actions, generalizing 'concatOf'. +-- +-- >>> msumOf both ("hello","world") +-- "helloworld" +-- +-- >>> msumOf each (Nothing, Just "hello", Nothing) +-- Just "hello" +-- +-- @ +-- 'msum' ≡ 'msumOf' 'folded' +-- @ +-- +-- @ +-- 'msumOf' :: 'MonadPlus' m => 'Getter' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Fold' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Lens'' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Iso'' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Traversal'' s (m a) -> s -> m a +-- 'msumOf' :: 'MonadPlus' m => 'Prism'' s (m a) -> s -> m a +-- @ +msumOf :: MonadPlus m => Getting (Endo (m a)) s (m a) -> s -> m a +msumOf l = foldrOf l mplus mzero +{-# INLINE msumOf #-} + +-- | Does the element occur anywhere within a given 'Fold' of the structure? +-- +-- >>> elemOf both "hello" ("hello","world") +-- True +-- +-- @ +-- 'elem' ≡ 'elemOf' 'folded' +-- @ +-- +-- @ +-- 'elemOf' :: 'Eq' a => 'Getter' s a -> a -> s -> 'Bool' +-- 'elemOf' :: 'Eq' a => 'Fold' s a -> a -> s -> 'Bool' +-- 'elemOf' :: 'Eq' a => 'Lens'' s a -> a -> s -> 'Bool' +-- 'elemOf' :: 'Eq' a => 'Iso'' s a -> a -> s -> 'Bool' +-- 'elemOf' :: 'Eq' a => 'Traversal'' s a -> a -> s -> 'Bool' +-- 'elemOf' :: 'Eq' a => 'Prism'' s a -> a -> s -> 'Bool' +-- @ +elemOf :: Eq a => Getting Any s a -> a -> s -> Bool +elemOf l = anyOf l . (==) +{-# INLINE elemOf #-} + +-- | Does the element not occur anywhere within a given 'Fold' of the structure? +-- +-- >>> notElemOf each 'd' ('a','b','c') +-- True +-- +-- >>> notElemOf each 'a' ('a','b','c') +-- False +-- +-- @ +-- 'notElem' ≡ 'notElemOf' 'folded' +-- @ +-- +-- @ +-- 'notElemOf' :: 'Eq' a => 'Getter' s a -> a -> s -> 'Bool' +-- 'notElemOf' :: 'Eq' a => 'Fold' s a -> a -> s -> 'Bool' +-- 'notElemOf' :: 'Eq' a => 'Iso'' s a -> a -> s -> 'Bool' +-- 'notElemOf' :: 'Eq' a => 'Lens'' s a -> a -> s -> 'Bool' +-- 'notElemOf' :: 'Eq' a => 'Traversal'' s a -> a -> s -> 'Bool' +-- 'notElemOf' :: 'Eq' a => 'Prism'' s a -> a -> s -> 'Bool' +-- @ +notElemOf :: Eq a => Getting All s a -> a -> s -> Bool +notElemOf l = allOf l . (/=) +{-# INLINE notElemOf #-} + +-- | Map a function over all the targets of a 'Fold' of a container and concatenate the resulting lists. +-- +-- >>> concatMapOf both (\x -> [x, x + 1]) (1,3) +-- [1,2,3,4] +-- +-- @ +-- 'concatMap' ≡ 'concatMapOf' 'folded' +-- @ +-- +-- @ +-- 'concatMapOf' :: 'Getter' s a -> (a -> [r]) -> s -> [r] +-- 'concatMapOf' :: 'Fold' s a -> (a -> [r]) -> s -> [r] +-- 'concatMapOf' :: 'Lens'' s a -> (a -> [r]) -> s -> [r] +-- 'concatMapOf' :: 'Iso'' s a -> (a -> [r]) -> s -> [r] +-- 'concatMapOf' :: 'Traversal'' s a -> (a -> [r]) -> s -> [r] +-- @ +concatMapOf :: Getting [r] s a -> (a -> [r]) -> s -> [r] +concatMapOf = coerce +{-# INLINE concatMapOf #-} + +-- | Concatenate all of the lists targeted by a 'Fold' into a longer list. +-- +-- >>> concatOf both ("pan","ama") +-- "panama" +-- +-- @ +-- 'concat' ≡ 'concatOf' 'folded' +-- 'concatOf' ≡ 'view' +-- @ +-- +-- @ +-- 'concatOf' :: 'Getter' s [r] -> s -> [r] +-- 'concatOf' :: 'Fold' s [r] -> s -> [r] +-- 'concatOf' :: 'Iso'' s [r] -> s -> [r] +-- 'concatOf' :: 'Lens'' s [r] -> s -> [r] +-- 'concatOf' :: 'Traversal'' s [r] -> s -> [r] +-- @ +concatOf :: Getting [r] s [r] -> s -> [r] +concatOf l = getConst #. l Const +{-# INLINE concatOf #-} + + +-- | Calculate the number of targets there are for a 'Fold' in a given container. +-- +-- /Note:/ This can be rather inefficient for large containers and just like 'length', +-- this will not terminate for infinite folds. +-- +-- @ +-- 'length' ≡ 'lengthOf' 'folded' +-- @ +-- +-- >>> lengthOf _1 ("hello",()) +-- 1 +-- +-- >>> lengthOf traverse [1..10] +-- 10 +-- +-- >>> lengthOf (traverse.traverse) [[1,2],[3,4],[5,6]] +-- 6 +-- +-- @ +-- 'lengthOf' ('folded' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a) -> 'Int' +-- @ +-- +-- @ +-- 'lengthOf' :: 'Getter' s a -> s -> 'Int' +-- 'lengthOf' :: 'Fold' s a -> s -> 'Int' +-- 'lengthOf' :: 'Lens'' s a -> s -> 'Int' +-- 'lengthOf' :: 'Iso'' s a -> s -> 'Int' +-- 'lengthOf' :: 'Traversal'' s a -> s -> 'Int' +-- @ +lengthOf :: Getting (Endo (Endo Int)) s a -> s -> Int +lengthOf l = foldlOf' l (\a _ -> a + 1) 0 +{-# INLINE lengthOf #-} + +-- | Perform a safe 'head' of a 'Fold' or 'Traversal' or retrieve 'Just' the result +-- from a 'Getter' or 'Lens'. +-- +-- When using a 'Traversal' as a partial 'Lens', or a 'Fold' as a partial 'Getter' this can be a convenient +-- way to extract the optional value. +-- +-- Note: if you get stack overflows due to this, you may want to use 'firstOf' instead, which can deal +-- more gracefully with heavily left-biased trees. This is because '^?' works by using the +-- 'Data.Monoid.First' monoid, which can occasionally cause space leaks. +-- +-- >>> Left 4 ^?_Left +-- Just 4 +-- +-- >>> Right 4 ^?_Left +-- Nothing +-- +-- >>> "world" ^? ix 3 +-- Just 'l' +-- +-- >>> "world" ^? ix 20 +-- Nothing +-- +-- This operator works as an infix version of 'preview'. +-- +-- @ +-- ('^?') ≡ 'flip' 'preview' +-- @ +-- +-- It may be helpful to think of '^?' as having one of the following +-- more specialized types: +-- +-- @ +-- ('^?') :: s -> 'Getter' s a -> 'Maybe' a +-- ('^?') :: s -> 'Fold' s a -> 'Maybe' a +-- ('^?') :: s -> 'Lens'' s a -> 'Maybe' a +-- ('^?') :: s -> 'Iso'' s a -> 'Maybe' a +-- ('^?') :: s -> 'Traversal'' s a -> 'Maybe' a +-- @ +(^?) :: s -> Getting (First a) s a -> Maybe a +s ^? l = getFirst (foldMapOf l (First #. Just) s) +{-# INLINE (^?) #-} + +-- | Perform an *UNSAFE* 'head' of a 'Fold' or 'Traversal' assuming that it is there. +-- +-- >>> Left 4 ^?! _Left +-- 4 +-- +-- >>> "world" ^?! ix 3 +-- 'l' +-- +-- @ +-- ('^?!') :: s -> 'Getter' s a -> a +-- ('^?!') :: s -> 'Fold' s a -> a +-- ('^?!') :: s -> 'Lens'' s a -> a +-- ('^?!') :: s -> 'Iso'' s a -> a +-- ('^?!') :: s -> 'Traversal'' s a -> a +-- @ +(^?!) :: HasCallStack => s -> Getting (Endo a) s a -> a +s ^?! l = foldrOf l const (error "(^?!): empty Fold") s +{-# INLINE (^?!) #-} + +-- | Retrieve the 'First' entry of a 'Fold' or 'Traversal' or retrieve 'Just' the result +-- from a 'Getter' or 'Lens'. +-- +-- The answer is computed in a manner that leaks space less than @'preview'@ or @^?'@ +-- and gives you back access to the outermost 'Just' constructor more quickly, but does so +-- in a way that builds an intermediate structure, and thus may have worse +-- constant factors. This also means that it can not be used in any 'Control.Monad.Reader.MonadReader', +-- but must instead have 's' passed as its last argument, unlike 'preview'. +-- +-- Note: this could been named `headOf`. +-- +-- >>> firstOf traverse [1..10] +-- Just 1 +-- +-- >>> firstOf both (1,2) +-- Just 1 +-- +-- >>> firstOf ignored () +-- Nothing +-- +-- @ +-- 'firstOf' :: 'Getter' s a -> s -> 'Maybe' a +-- 'firstOf' :: 'Fold' s a -> s -> 'Maybe' a +-- 'firstOf' :: 'Lens'' s a -> s -> 'Maybe' a +-- 'firstOf' :: 'Iso'' s a -> s -> 'Maybe' a +-- 'firstOf' :: 'Traversal'' s a -> s -> 'Maybe' a +-- @ +firstOf :: Getting (Leftmost a) s a -> s -> Maybe a +firstOf l = getLeftmost . foldMapOf l LLeaf +{-# INLINE firstOf #-} + +-- | Retrieve the 'Data.Semigroup.First' entry of a 'Fold1' or 'Traversal1' or the result from a 'Getter' or 'Lens'. +-- +-- >>> first1Of traverse1 (1 :| [2..10]) +-- 1 +-- +-- >>> first1Of both1 (1,2) +-- 1 +-- +-- /Note:/ this is different from '^.'. +-- +-- >>> first1Of traverse1 ([1,2] :| [[3,4],[5,6]]) +-- [1,2] +-- +-- >>> ([1,2] :| [[3,4],[5,6]]) ^. traverse1 +-- [1,2,3,4,5,6] +-- +-- @ +-- 'first1Of' :: 'Getter' s a -> s -> a +-- 'first1Of' :: 'Fold1' s a -> s -> a +-- 'first1Of' :: 'Lens'' s a -> s -> a +-- 'first1Of' :: 'Iso'' s a -> s -> a +-- 'first1Of' :: 'Traversal1'' s a -> s -> a +-- @ +first1Of :: Getting (Semi.First a) s a -> s -> a +first1Of l = Semi.getFirst . foldMapOf l Semi.First + +-- | Retrieve the 'Last' entry of a 'Fold' or 'Traversal' or retrieve 'Just' the result +-- from a 'Getter' or 'Lens'. +-- +-- The answer is computed in a manner that leaks space less than @'ala' 'Last' '.' 'foldMapOf'@ +-- and gives you back access to the outermost 'Just' constructor more quickly, but may have worse +-- constant factors. +-- +-- >>> lastOf traverse [1..10] +-- Just 10 +-- +-- >>> lastOf both (1,2) +-- Just 2 +-- +-- >>> lastOf ignored () +-- Nothing +-- +-- @ +-- 'lastOf' :: 'Getter' s a -> s -> 'Maybe' a +-- 'lastOf' :: 'Fold' s a -> s -> 'Maybe' a +-- 'lastOf' :: 'Lens'' s a -> s -> 'Maybe' a +-- 'lastOf' :: 'Iso'' s a -> s -> 'Maybe' a +-- 'lastOf' :: 'Traversal'' s a -> s -> 'Maybe' a +-- @ +lastOf :: Getting (Rightmost a) s a -> s -> Maybe a +lastOf l = getRightmost . foldMapOf l RLeaf +{-# INLINE lastOf #-} + +-- | Retrieve the 'Data.Semigroup.Last' entry of a 'Fold1' or 'Traversal1' or retrieve the result +-- from a 'Getter' or 'Lens'.o +-- +-- >>> last1Of traverse1 (1 :| [2..10]) +-- 10 +-- +-- >>> last1Of both1 (1,2) +-- 2 +-- +-- @ +-- 'last1Of' :: 'Getter' s a -> s -> 'Maybe' a +-- 'last1Of' :: 'Fold1' s a -> s -> 'Maybe' a +-- 'last1Of' :: 'Lens'' s a -> s -> 'Maybe' a +-- 'last1Of' :: 'Iso'' s a -> s -> 'Maybe' a +-- 'last1Of' :: 'Traversal1'' s a -> s -> 'Maybe' a +-- @ +last1Of :: Getting (Semi.Last a) s a -> s -> a +last1Of l = Semi.getLast . foldMapOf l Semi.Last + +-- | Returns 'True' if this 'Fold' or 'Traversal' has no targets in the given container. +-- +-- Note: 'nullOf' on a valid 'Iso', 'Lens' or 'Getter' should always return 'False'. +-- +-- @ +-- 'null' ≡ 'nullOf' 'folded' +-- @ +-- +-- This may be rather inefficient compared to the 'null' check of many containers. +-- +-- >>> nullOf _1 (1,2) +-- False +-- +-- >>> nullOf ignored () +-- True +-- +-- >>> nullOf traverse [] +-- True +-- +-- >>> nullOf (element 20) [1..10] +-- True +-- +-- @ +-- 'nullOf' ('folded' '.' '_1' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a, b) -> 'Bool' +-- @ +-- +-- @ +-- 'nullOf' :: 'Getter' s a -> s -> 'Bool' +-- 'nullOf' :: 'Fold' s a -> s -> 'Bool' +-- 'nullOf' :: 'Iso'' s a -> s -> 'Bool' +-- 'nullOf' :: 'Lens'' s a -> s -> 'Bool' +-- 'nullOf' :: 'Traversal'' s a -> s -> 'Bool' +-- @ +nullOf :: Getting All s a -> s -> Bool +nullOf = hasn't +{-# INLINE nullOf #-} + +-- | Returns 'True' if this 'Fold' or 'Traversal' has any targets in the given container. +-- +-- A more \"conversational\" alias for this combinator is 'has'. +-- +-- Note: 'notNullOf' on a valid 'Iso', 'Lens' or 'Getter' should always return 'True'. +-- +-- @ +-- 'not' '.' 'null' ≡ 'notNullOf' 'folded' +-- @ +-- +-- This may be rather inefficient compared to the @'not' '.' 'null'@ check of many containers. +-- +-- >>> notNullOf _1 (1,2) +-- True +-- +-- >>> notNullOf traverse [1..10] +-- True +-- +-- >>> notNullOf folded [] +-- False +-- +-- >>> notNullOf (element 20) [1..10] +-- False +-- +-- @ +-- 'notNullOf' ('folded' '.' '_1' '.' 'folded') :: ('Foldable' f, 'Foldable' g) => f (g a, b) -> 'Bool' +-- @ +-- +-- @ +-- 'notNullOf' :: 'Getter' s a -> s -> 'Bool' +-- 'notNullOf' :: 'Fold' s a -> s -> 'Bool' +-- 'notNullOf' :: 'Iso'' s a -> s -> 'Bool' +-- 'notNullOf' :: 'Lens'' s a -> s -> 'Bool' +-- 'notNullOf' :: 'Traversal'' s a -> s -> 'Bool' +-- @ +notNullOf :: Getting Any s a -> s -> Bool +notNullOf = has +{-# INLINE notNullOf #-} + +-- | Obtain the maximum element (if any) targeted by a 'Fold' or 'Traversal' safely. +-- +-- Note: 'maximumOf' on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. +-- +-- >>> maximumOf traverse [1..10] +-- Just 10 +-- +-- >>> maximumOf traverse [] +-- Nothing +-- +-- >>> maximumOf (folded.filtered even) [1,4,3,6,7,9,2] +-- Just 6 +-- +-- @ +-- 'maximum' ≡ 'fromMaybe' ('error' \"empty\") '.' 'maximumOf' 'folded' +-- @ +-- +-- In the interest of efficiency, This operation has semantics more strict than strictly necessary. +-- @'rmap' 'getMax' ('foldMapOf' l 'Max')@ has lazier semantics but could leak memory. +-- +-- @ +-- 'maximumOf' :: 'Ord' a => 'Getter' s a -> s -> 'Maybe' a +-- 'maximumOf' :: 'Ord' a => 'Fold' s a -> s -> 'Maybe' a +-- 'maximumOf' :: 'Ord' a => 'Iso'' s a -> s -> 'Maybe' a +-- 'maximumOf' :: 'Ord' a => 'Lens'' s a -> s -> 'Maybe' a +-- 'maximumOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Maybe' a +-- @ +maximumOf :: Ord a => Getting (Endo (Endo (Maybe a))) s a -> s -> Maybe a +maximumOf l = foldlOf' l mf Nothing where + mf Nothing y = Just $! y + mf (Just x) y = Just $! max x y +{-# INLINE maximumOf #-} + +-- | Obtain the maximum element targeted by a 'Fold1' or 'Traversal1'. +-- +-- >>> maximum1Of traverse1 (1 :| [2..10]) +-- 10 +-- +-- @ +-- 'maximum1Of' :: 'Ord' a => 'Getter' s a -> s -> a +-- 'maximum1Of' :: 'Ord' a => 'Fold1' s a -> s -> a +-- 'maximum1Of' :: 'Ord' a => 'Iso'' s a -> s -> a +-- 'maximum1Of' :: 'Ord' a => 'Lens'' s a -> s -> a +-- 'maximum1Of' :: 'Ord' a => 'Traversal1'' s a -> s -> a +-- @ +maximum1Of :: Ord a => Getting (Semi.Max a) s a -> s -> a +maximum1Of l = Semi.getMax . foldMapOf l Semi.Max +{-# INLINE maximum1Of #-} + +-- | Obtain the minimum element (if any) targeted by a 'Fold' or 'Traversal' safely. +-- +-- Note: 'minimumOf' on a valid 'Iso', 'Lens' or 'Getter' will always return 'Just' a value. +-- +-- >>> minimumOf traverse [1..10] +-- Just 1 +-- +-- >>> minimumOf traverse [] +-- Nothing +-- +-- >>> minimumOf (folded.filtered even) [1,4,3,6,7,9,2] +-- Just 2 +-- +-- @ +-- 'minimum' ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumOf' 'folded' +-- @ +-- +-- In the interest of efficiency, This operation has semantics more strict than strictly necessary. +-- @'rmap' 'getMin' ('foldMapOf' l 'Min')@ has lazier semantics but could leak memory. +-- +-- +-- @ +-- 'minimumOf' :: 'Ord' a => 'Getter' s a -> s -> 'Maybe' a +-- 'minimumOf' :: 'Ord' a => 'Fold' s a -> s -> 'Maybe' a +-- 'minimumOf' :: 'Ord' a => 'Iso'' s a -> s -> 'Maybe' a +-- 'minimumOf' :: 'Ord' a => 'Lens'' s a -> s -> 'Maybe' a +-- 'minimumOf' :: 'Ord' a => 'Traversal'' s a -> s -> 'Maybe' a +-- @ +minimumOf :: Ord a => Getting (Endo (Endo (Maybe a))) s a -> s -> Maybe a +minimumOf l = foldlOf' l mf Nothing where + mf Nothing y = Just $! y + mf (Just x) y = Just $! min x y +{-# INLINE minimumOf #-} + +-- | Obtain the minimum element targeted by a 'Fold1' or 'Traversal1'. +-- +-- >>> minimum1Of traverse1 (1 :| [2..10]) +-- 1 +-- +-- @ +-- 'minimum1Of' :: 'Ord' a => 'Getter' s a -> s -> a +-- 'minimum1Of' :: 'Ord' a => 'Fold1' s a -> s -> a +-- 'minimum1Of' :: 'Ord' a => 'Iso'' s a -> s -> a +-- 'minimum1Of' :: 'Ord' a => 'Lens'' s a -> s -> a +-- 'minimum1Of' :: 'Ord' a => 'Traversal1'' s a -> s -> a +-- @ +minimum1Of :: Ord a => Getting (Semi.Min a) s a -> s -> a +minimum1Of l = Semi.getMin . foldMapOf l Semi.Min +{-# INLINE minimum1Of #-} + +-- | Obtain the maximum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso', +-- or 'Getter' according to a user supplied 'Ordering'. +-- +-- >>> maximumByOf traverse (compare `on` length) ["mustard","relish","ham"] +-- Just "mustard" +-- +-- In the interest of efficiency, This operation has semantics more strict than strictly necessary. +-- +-- @ +-- 'Data.Foldable.maximumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'maximumByOf' 'folded' cmp +-- @ +-- +-- @ +-- 'maximumByOf' :: 'Getter' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- 'maximumByOf' :: 'Fold' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- 'maximumByOf' :: 'Iso'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- 'maximumByOf' :: 'Lens'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- 'maximumByOf' :: 'Traversal'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- @ +maximumByOf :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> Ordering) -> s -> Maybe a +maximumByOf l cmp = foldlOf' l mf Nothing where + mf Nothing y = Just $! y + mf (Just x) y = Just $! if cmp x y == GT then x else y +{-# INLINE maximumByOf #-} + +-- | Obtain the minimum element (if any) targeted by a 'Fold', 'Traversal', 'Lens', 'Iso' +-- or 'Getter' according to a user supplied 'Ordering'. +-- +-- In the interest of efficiency, This operation has semantics more strict than strictly necessary. +-- +-- >>> minimumByOf traverse (compare `on` length) ["mustard","relish","ham"] +-- Just "ham" +-- +-- @ +-- 'minimumBy' cmp ≡ 'Data.Maybe.fromMaybe' ('error' \"empty\") '.' 'minimumByOf' 'folded' cmp +-- @ +-- +-- @ +-- 'minimumByOf' :: 'Getter' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- 'minimumByOf' :: 'Fold' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- 'minimumByOf' :: 'Iso'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- 'minimumByOf' :: 'Lens'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- 'minimumByOf' :: 'Traversal'' s a -> (a -> a -> 'Ordering') -> s -> 'Maybe' a +-- @ +minimumByOf :: Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> Ordering) -> s -> Maybe a +minimumByOf l cmp = foldlOf' l mf Nothing where + mf Nothing y = Just $! y + mf (Just x) y = Just $! if cmp x y == GT then y else x +{-# INLINE minimumByOf #-} + +-- | The 'findOf' function takes a 'Lens' (or 'Getter', 'Iso', 'Fold', or 'Traversal'), +-- a predicate and a structure and returns the leftmost element of the structure +-- matching the predicate, or 'Nothing' if there is no such element. +-- +-- >>> findOf each even (1,3,4,6) +-- Just 4 +-- +-- >>> findOf folded even [1,3,5,7] +-- Nothing +-- +-- @ +-- 'findOf' :: 'Getter' s a -> (a -> 'Bool') -> s -> 'Maybe' a +-- 'findOf' :: 'Fold' s a -> (a -> 'Bool') -> s -> 'Maybe' a +-- 'findOf' :: 'Iso'' s a -> (a -> 'Bool') -> s -> 'Maybe' a +-- 'findOf' :: 'Lens'' s a -> (a -> 'Bool') -> s -> 'Maybe' a +-- 'findOf' :: 'Traversal'' s a -> (a -> 'Bool') -> s -> 'Maybe' a +-- @ +-- +-- @ +-- 'Data.Foldable.find' ≡ 'findOf' 'folded' +-- 'ifindOf' l ≡ 'findOf' l '.' 'Indexed' +-- @ +-- +-- A simpler version that didn't permit indexing, would be: +-- +-- @ +-- 'findOf' :: 'Getting' ('Endo' ('Maybe' a)) s a -> (a -> 'Bool') -> s -> 'Maybe' a +-- 'findOf' l p = 'foldrOf' l (\a y -> if p a then 'Just' a else y) 'Nothing' +-- @ +findOf :: Getting (Endo (Maybe a)) s a -> (a -> Bool) -> s -> Maybe a +findOf l f = foldrOf l (\a y -> if f a then Just a else y) Nothing +{-# INLINE findOf #-} + +-- | The 'findMOf' function takes a 'Lens' (or 'Getter', 'Iso', 'Fold', or 'Traversal'), +-- a monadic predicate and a structure and returns in the monad the leftmost element of the structure +-- matching the predicate, or 'Nothing' if there is no such element. +-- +-- >>> findMOf each ( \x -> print ("Checking " ++ show x) >> return (even x)) (1,3,4,6) +-- "Checking 1" +-- "Checking 3" +-- "Checking 4" +-- Just 4 +-- +-- >>> findMOf each ( \x -> print ("Checking " ++ show x) >> return (even x)) (1,3,5,7) +-- "Checking 1" +-- "Checking 3" +-- "Checking 5" +-- "Checking 7" +-- Nothing +-- +-- @ +-- 'findMOf' :: ('Monad' m, 'Getter' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) +-- 'findMOf' :: ('Monad' m, 'Fold' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) +-- 'findMOf' :: ('Monad' m, 'Iso'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) +-- 'findMOf' :: ('Monad' m, 'Lens'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) +-- 'findMOf' :: ('Monad' m, 'Traversal'' s a) -> (a -> m 'Bool') -> s -> m ('Maybe' a) +-- @ +-- +-- @ +-- 'findMOf' 'folded' :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m (Maybe a) +-- 'ifindMOf' l ≡ 'findMOf' l '.' 'Indexed' +-- @ +-- +-- A simpler version that didn't permit indexing, would be: +-- +-- @ +-- 'findMOf' :: Monad m => 'Getting' ('Endo' (m ('Maybe' a))) s a -> (a -> m 'Bool') -> s -> m ('Maybe' a) +-- 'findMOf' l p = 'foldrOf' l (\a y -> p a >>= \x -> if x then return ('Just' a) else y) $ return 'Nothing' +-- @ +findMOf :: Monad m => Getting (Endo (m (Maybe a))) s a -> (a -> m Bool) -> s -> m (Maybe a) +findMOf l f = foldrOf l (\a y -> f a >>= \r -> if r then return (Just a) else y) $ return Nothing +{-# INLINE findMOf #-} + +-- | The 'lookupOf' function takes a 'Fold' (or 'Getter', 'Traversal', +-- 'Lens', 'Iso', etc.), a key, and a structure containing key/value pairs. +-- It returns the first value corresponding to the given key. This function +-- generalizes 'lookup' to work on an arbitrary 'Fold' instead of lists. +-- +-- >>> lookupOf folded 4 [(2, 'a'), (4, 'b'), (4, 'c')] +-- Just 'b' +-- +-- >>> lookupOf each 2 [(2, 'a'), (4, 'b'), (4, 'c')] +-- Just 'a' +-- +-- @ +-- 'lookupOf' :: 'Eq' k => 'Fold' s (k,v) -> k -> s -> 'Maybe' v +-- @ +lookupOf :: Eq k => Getting (Endo (Maybe v)) s (k,v) -> k -> s -> Maybe v +lookupOf l k = foldrOf l (\(k',v) next -> if k == k' then Just v else next) Nothing +{-# INLINE lookupOf #-} + +-- | A variant of 'foldrOf' that has no base case and thus may only be applied +-- to lenses and structures such that the 'Lens' views at least one element of +-- the structure. +-- +-- >>> foldr1Of each (+) (1,2,3,4) +-- 10 +-- +-- @ +-- 'foldr1Of' l f ≡ 'Prelude.foldr1' f '.' 'toListOf' l +-- 'Data.Foldable.foldr1' ≡ 'foldr1Of' 'folded' +-- @ +-- +-- @ +-- 'foldr1Of' :: 'Getter' s a -> (a -> a -> a) -> s -> a +-- 'foldr1Of' :: 'Fold' s a -> (a -> a -> a) -> s -> a +-- 'foldr1Of' :: 'Iso'' s a -> (a -> a -> a) -> s -> a +-- 'foldr1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a +-- 'foldr1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a +-- @ +foldr1Of :: HasCallStack => Getting (Endo (Maybe a)) s a -> (a -> a -> a) -> s -> a +foldr1Of l f xs = fromMaybe (error "foldr1Of: empty structure") + (foldrOf l mf Nothing xs) where + mf x my = Just $ case my of + Nothing -> x + Just y -> f x y +{-# INLINE foldr1Of #-} + +-- | A variant of 'foldlOf' that has no base case and thus may only be applied to lenses and structures such +-- that the 'Lens' views at least one element of the structure. +-- +-- >>> foldl1Of each (+) (1,2,3,4) +-- 10 +-- +-- @ +-- 'foldl1Of' l f ≡ 'Prelude.foldl1' f '.' 'toListOf' l +-- 'Data.Foldable.foldl1' ≡ 'foldl1Of' 'folded' +-- @ +-- +-- @ +-- 'foldl1Of' :: 'Getter' s a -> (a -> a -> a) -> s -> a +-- 'foldl1Of' :: 'Fold' s a -> (a -> a -> a) -> s -> a +-- 'foldl1Of' :: 'Iso'' s a -> (a -> a -> a) -> s -> a +-- 'foldl1Of' :: 'Lens'' s a -> (a -> a -> a) -> s -> a +-- 'foldl1Of' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a +-- @ +foldl1Of :: HasCallStack => Getting (Dual (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a +foldl1Of l f xs = fromMaybe (error "foldl1Of: empty structure") (foldlOf l mf Nothing xs) where + mf mx y = Just $ case mx of + Nothing -> y + Just x -> f x y +{-# INLINE foldl1Of #-} + +-- | Strictly fold right over the elements of a structure. +-- +-- @ +-- 'Data.Foldable.foldr'' ≡ 'foldrOf'' 'folded' +-- @ +-- +-- @ +-- 'foldrOf'' :: 'Getter' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf'' :: 'Fold' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf'' :: 'Iso'' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf'' :: 'Lens'' s a -> (a -> r -> r) -> r -> s -> r +-- 'foldrOf'' :: 'Traversal'' s a -> (a -> r -> r) -> r -> s -> r +-- @ +foldrOf' :: Getting (Dual (Endo (Endo r))) s a -> (a -> r -> r) -> r -> s -> r +foldrOf' l f z0 xs = foldlOf l f' (Endo id) xs `appEndo` z0 + where f' (Endo k) x = Endo $ \ z -> k $! f x z +{-# INLINE foldrOf' #-} + +-- | Fold over the elements of a structure, associating to the left, but strictly. +-- +-- @ +-- 'Data.Foldable.foldl'' ≡ 'foldlOf'' 'folded' +-- @ +-- +-- @ +-- 'foldlOf'' :: 'Getter' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf'' :: 'Fold' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf'' :: 'Iso'' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf'' :: 'Lens'' s a -> (r -> a -> r) -> r -> s -> r +-- 'foldlOf'' :: 'Traversal'' s a -> (r -> a -> r) -> r -> s -> r +-- @ +foldlOf' :: Getting (Endo (Endo r)) s a -> (r -> a -> r) -> r -> s -> r +foldlOf' l f z0 xs = foldrOf l f' (Endo id) xs `appEndo` z0 + where f' x (Endo k) = Endo $ \z -> k $! f z x +{-# INLINE foldlOf' #-} + +-- | A variant of 'foldrOf'' that has no base case and thus may only be applied +-- to folds and structures such that the fold views at least one element of the +-- structure. +-- +-- @ +-- 'foldr1Of' l f ≡ 'Prelude.foldr1' f '.' 'toListOf' l +-- @ +-- +-- @ +-- 'foldr1Of'' :: 'Getter' s a -> (a -> a -> a) -> s -> a +-- 'foldr1Of'' :: 'Fold' s a -> (a -> a -> a) -> s -> a +-- 'foldr1Of'' :: 'Iso'' s a -> (a -> a -> a) -> s -> a +-- 'foldr1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a +-- 'foldr1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a +-- @ +foldr1Of' :: HasCallStack => Getting (Dual (Endo (Endo (Maybe a)))) s a -> (a -> a -> a) -> s -> a +foldr1Of' l f xs = fromMaybe (error "foldr1Of': empty structure") (foldrOf' l mf Nothing xs) where + mf x Nothing = Just $! x + mf x (Just y) = Just $! f x y +{-# INLINE foldr1Of' #-} + +-- | A variant of 'foldlOf'' that has no base case and thus may only be applied +-- to folds and structures such that the fold views at least one element of +-- the structure. +-- +-- @ +-- 'foldl1Of'' l f ≡ 'Data.List.foldl1'' f '.' 'toListOf' l +-- @ +-- +-- @ +-- 'foldl1Of'' :: 'Getter' s a -> (a -> a -> a) -> s -> a +-- 'foldl1Of'' :: 'Fold' s a -> (a -> a -> a) -> s -> a +-- 'foldl1Of'' :: 'Iso'' s a -> (a -> a -> a) -> s -> a +-- 'foldl1Of'' :: 'Lens'' s a -> (a -> a -> a) -> s -> a +-- 'foldl1Of'' :: 'Traversal'' s a -> (a -> a -> a) -> s -> a +-- @ +foldl1Of' :: HasCallStack => Getting (Endo (Endo (Maybe a))) s a -> (a -> a -> a) -> s -> a +foldl1Of' l f xs = fromMaybe (error "foldl1Of': empty structure") (foldlOf' l mf Nothing xs) where + mf Nothing y = Just $! y + mf (Just x) y = Just $! f x y +{-# INLINE foldl1Of' #-} + +-- | Monadic fold over the elements of a structure, associating to the right, +-- i.e. from right to left. +-- +-- @ +-- 'Data.Foldable.foldrM' ≡ 'foldrMOf' 'folded' +-- @ +-- +-- @ +-- 'foldrMOf' :: 'Monad' m => 'Getter' s a -> (a -> r -> m r) -> r -> s -> m r +-- 'foldrMOf' :: 'Monad' m => 'Fold' s a -> (a -> r -> m r) -> r -> s -> m r +-- 'foldrMOf' :: 'Monad' m => 'Iso'' s a -> (a -> r -> m r) -> r -> s -> m r +-- 'foldrMOf' :: 'Monad' m => 'Lens'' s a -> (a -> r -> m r) -> r -> s -> m r +-- 'foldrMOf' :: 'Monad' m => 'Traversal'' s a -> (a -> r -> m r) -> r -> s -> m r +-- @ +foldrMOf :: Monad m + => Getting (Dual (Endo (r -> m r))) s a + -> (a -> r -> m r) -> r -> s -> m r +foldrMOf l f z0 xs = foldlOf l f' return xs z0 + where f' k x z = f x z >>= k +{-# INLINE foldrMOf #-} + +-- | Monadic fold over the elements of a structure, associating to the left, +-- i.e. from left to right. +-- +-- @ +-- 'Data.Foldable.foldlM' ≡ 'foldlMOf' 'folded' +-- @ +-- +-- @ +-- 'foldlMOf' :: 'Monad' m => 'Getter' s a -> (r -> a -> m r) -> r -> s -> m r +-- 'foldlMOf' :: 'Monad' m => 'Fold' s a -> (r -> a -> m r) -> r -> s -> m r +-- 'foldlMOf' :: 'Monad' m => 'Iso'' s a -> (r -> a -> m r) -> r -> s -> m r +-- 'foldlMOf' :: 'Monad' m => 'Lens'' s a -> (r -> a -> m r) -> r -> s -> m r +-- 'foldlMOf' :: 'Monad' m => 'Traversal'' s a -> (r -> a -> m r) -> r -> s -> m r +-- @ +foldlMOf :: Monad m + => Getting (Endo (r -> m r)) s a + -> (r -> a -> m r) -> r -> s -> m r +foldlMOf l f z0 xs = foldrOf l f' return xs z0 + where f' x k z = f z x >>= k +{-# INLINE foldlMOf #-} + +-- | Check to see if this 'Fold' or 'Traversal' matches 1 or more entries. +-- +-- >>> has (element 0) [] +-- False +-- +-- >>> has _Left (Left 12) +-- True +-- +-- >>> has _Right (Left 12) +-- False +-- +-- This will always return 'True' for a 'Lens' or 'Getter'. +-- +-- >>> has _1 ("hello","world") +-- True +-- +-- @ +-- 'has' :: 'Getter' s a -> s -> 'Bool' +-- 'has' :: 'Fold' s a -> s -> 'Bool' +-- 'has' :: 'Iso'' s a -> s -> 'Bool' +-- 'has' :: 'Lens'' s a -> s -> 'Bool' +-- 'has' :: 'Traversal'' s a -> s -> 'Bool' +-- @ +has :: Getting Any s a -> s -> Bool +has l = getAny #. foldMapOf l (\_ -> Any True) +{-# INLINE has #-} + + + +-- | Check to see if this 'Fold' or 'Traversal' has no matches. +-- +-- >>> hasn't _Left (Right 12) +-- True +-- +-- >>> hasn't _Left (Left 12) +-- False +hasn't :: Getting All s a -> s -> Bool +hasn't l = getAll #. foldMapOf l (\_ -> All False) +{-# INLINE hasn't #-} + +------------------------------------------------------------------------------ +-- Pre +------------------------------------------------------------------------------ + +-- | This converts a 'Fold' to a 'IndexPreservingGetter' that returns the first element, if it +-- exists, as a 'Maybe'. +-- +-- @ +-- 'pre' :: 'Getter' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Fold' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Traversal'' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Lens'' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Iso'' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- 'pre' :: 'Prism'' s a -> 'IndexPreservingGetter' s ('Maybe' a) +-- @ +pre :: Getting (First a) s a -> IndexPreservingGetter s (Maybe a) +pre l = dimap (getFirst . getConst #. l (Const #. First #. Just)) phantom +{-# INLINE pre #-} + +-- | This converts an 'IndexedFold' to an 'IndexPreservingGetter' that returns the first index +-- and element, if they exist, as a 'Maybe'. +-- +-- @ +-- 'ipre' :: 'IndexedGetter' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- 'ipre' :: 'IndexedFold' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- 'ipre' :: 'IndexedTraversal'' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- 'ipre' :: 'IndexedLens'' i s a -> 'IndexPreservingGetter' s ('Maybe' (i, a)) +-- @ +ipre :: IndexedGetting i (First (i, a)) s a -> IndexPreservingGetter s (Maybe (i, a)) +ipre l = dimap (getFirst . getConst #. l (Indexed $ \i a -> Const (First (Just (i, a))))) phantom +{-# INLINE ipre #-} + +------------------------------------------------------------------------------ +-- Preview +------------------------------------------------------------------------------ + +-- | Retrieve the first value targeted by a 'Fold' or 'Traversal' (or 'Just' the result +-- from a 'Getter' or 'Lens'). See also 'firstOf' and '^?', which are similar with +-- some subtle differences (explained below). +-- +-- @ +-- 'Data.Maybe.listToMaybe' '.' 'toList' ≡ 'preview' 'folded' +-- @ +-- +-- @ +-- 'preview' = 'view' '.' 'pre' +-- @ +-- +-- +-- Unlike '^?', this function uses a +-- 'Control.Monad.Reader.MonadReader' to read the value to be focused in on. +-- This allows one to pass the value as the last argument by using the +-- 'Control.Monad.Reader.MonadReader' instance for @(->) s@ +-- However, it may also be used as part of some deeply nested transformer stack. +-- +-- 'preview' uses a monoidal value to obtain the result. +-- This means that it generally has good performance, but can occasionally cause space leaks +-- or even stack overflows on some data types. +-- There is another function, 'firstOf', which avoids these issues at the cost of +-- a slight constant performance cost and a little less flexibility. +-- +-- It may be helpful to think of 'preview' as having one of the following +-- more specialized types: +-- +-- @ +-- 'preview' :: 'Getter' s a -> s -> 'Maybe' a +-- 'preview' :: 'Fold' s a -> s -> 'Maybe' a +-- 'preview' :: 'Lens'' s a -> s -> 'Maybe' a +-- 'preview' :: 'Iso'' s a -> s -> 'Maybe' a +-- 'preview' :: 'Traversal'' s a -> s -> 'Maybe' a +-- @ +-- +-- +-- @ +-- 'preview' :: 'MonadReader' s m => 'Getter' s a -> m ('Maybe' a) +-- 'preview' :: 'MonadReader' s m => 'Fold' s a -> m ('Maybe' a) +-- 'preview' :: 'MonadReader' s m => 'Lens'' s a -> m ('Maybe' a) +-- 'preview' :: 'MonadReader' s m => 'Iso'' s a -> m ('Maybe' a) +-- 'preview' :: 'MonadReader' s m => 'Traversal'' s a -> m ('Maybe' a) +-- +-- @ +preview :: MonadReader s m => Getting (First a) s a -> m (Maybe a) +preview l = asks (getFirst #. foldMapOf l (First #. Just)) +{-# INLINE preview #-} + +-- | Retrieve the first index and value targeted by a 'Fold' or 'Traversal' (or 'Just' the result +-- from a 'Getter' or 'Lens'). See also ('^@?'). +-- +-- @ +-- 'ipreview' = 'view' '.' 'ipre' +-- @ +-- +-- This is usually applied in the 'Control.Monad.Reader.Reader' +-- 'Control.Monad.Monad' @(->) s@. +-- +-- @ +-- 'ipreview' :: 'IndexedGetter' i s a -> s -> 'Maybe' (i, a) +-- 'ipreview' :: 'IndexedFold' i s a -> s -> 'Maybe' (i, a) +-- 'ipreview' :: 'IndexedLens'' i s a -> s -> 'Maybe' (i, a) +-- 'ipreview' :: 'IndexedTraversal'' i s a -> s -> 'Maybe' (i, a) +-- @ +-- +-- However, it may be useful to think of its full generality when working with +-- a 'Control.Monad.Monad' transformer stack: +-- +-- @ +-- 'ipreview' :: 'MonadReader' s m => 'IndexedGetter' s a -> m ('Maybe' (i, a)) +-- 'ipreview' :: 'MonadReader' s m => 'IndexedFold' s a -> m ('Maybe' (i, a)) +-- 'ipreview' :: 'MonadReader' s m => 'IndexedLens'' s a -> m ('Maybe' (i, a)) +-- 'ipreview' :: 'MonadReader' s m => 'IndexedTraversal'' s a -> m ('Maybe' (i, a)) +-- @ +ipreview :: MonadReader s m => IndexedGetting i (First (i, a)) s a -> m (Maybe (i, a)) +ipreview l = asks (getFirst #. ifoldMapOf l (\i a -> First (Just (i, a)))) +{-# INLINE ipreview #-} + +-- | Retrieve a function of the first value targeted by a 'Fold' or +-- 'Traversal' (or 'Just' the result from a 'Getter' or 'Lens'). +-- +-- This is usually applied in the 'Control.Monad.Reader.Reader' +-- 'Control.Monad.Monad' @(->) s@. + +-- @ +-- 'previews' = 'views' '.' 'pre' +-- @ +-- +-- @ +-- 'previews' :: 'Getter' s a -> (a -> r) -> s -> 'Maybe' r +-- 'previews' :: 'Fold' s a -> (a -> r) -> s -> 'Maybe' r +-- 'previews' :: 'Lens'' s a -> (a -> r) -> s -> 'Maybe' r +-- 'previews' :: 'Iso'' s a -> (a -> r) -> s -> 'Maybe' r +-- 'previews' :: 'Traversal'' s a -> (a -> r) -> s -> 'Maybe' r +-- @ +-- +-- However, it may be useful to think of its full generality when working with +-- a 'Monad' transformer stack: +-- +-- @ +-- 'previews' :: 'MonadReader' s m => 'Getter' s a -> (a -> r) -> m ('Maybe' r) +-- 'previews' :: 'MonadReader' s m => 'Fold' s a -> (a -> r) -> m ('Maybe' r) +-- 'previews' :: 'MonadReader' s m => 'Lens'' s a -> (a -> r) -> m ('Maybe' r) +-- 'previews' :: 'MonadReader' s m => 'Iso'' s a -> (a -> r) -> m ('Maybe' r) +-- 'previews' :: 'MonadReader' s m => 'Traversal'' s a -> (a -> r) -> m ('Maybe' r) +-- @ +previews :: MonadReader s m => Getting (First r) s a -> (a -> r) -> m (Maybe r) +previews l f = asks (getFirst . foldMapOf l (First #. Just . f)) +{-# INLINE previews #-} + +-- | Retrieve a function of the first index and value targeted by an 'IndexedFold' or +-- 'IndexedTraversal' (or 'Just' the result from an 'IndexedGetter' or 'IndexedLens'). +-- See also ('^@?'). +-- +-- @ +-- 'ipreviews' = 'views' '.' 'ipre' +-- @ +-- +-- This is usually applied in the 'Control.Monad.Reader.Reader' +-- 'Control.Monad.Monad' @(->) s@. +-- +-- @ +-- 'ipreviews' :: 'IndexedGetter' i s a -> (i -> a -> r) -> s -> 'Maybe' r +-- 'ipreviews' :: 'IndexedFold' i s a -> (i -> a -> r) -> s -> 'Maybe' r +-- 'ipreviews' :: 'IndexedLens'' i s a -> (i -> a -> r) -> s -> 'Maybe' r +-- 'ipreviews' :: 'IndexedTraversal'' i s a -> (i -> a -> r) -> s -> 'Maybe' r +-- @ +-- +-- However, it may be useful to think of its full generality when working with +-- a 'Control.Monad.Monad' transformer stack: +-- +-- @ +-- 'ipreviews' :: 'MonadReader' s m => 'IndexedGetter' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreviews' :: 'MonadReader' s m => 'IndexedFold' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreviews' :: 'MonadReader' s m => 'IndexedLens'' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreviews' :: 'MonadReader' s m => 'IndexedTraversal'' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- @ +ipreviews :: MonadReader s m => IndexedGetting i (First r) s a -> (i -> a -> r) -> m (Maybe r) +ipreviews l f = asks (getFirst . ifoldMapOf l (\i -> First #. Just . f i)) +{-# INLINE ipreviews #-} + +------------------------------------------------------------------------------ +-- Preuse +------------------------------------------------------------------------------ + +-- | Retrieve the first value targeted by a 'Fold' or 'Traversal' (or 'Just' the result +-- from a 'Getter' or 'Lens') into the current state. +-- +-- @ +-- 'preuse' = 'use' '.' 'pre' +-- @ +-- +-- @ +-- 'preuse' :: 'MonadState' s m => 'Getter' s a -> m ('Maybe' a) +-- 'preuse' :: 'MonadState' s m => 'Fold' s a -> m ('Maybe' a) +-- 'preuse' :: 'MonadState' s m => 'Lens'' s a -> m ('Maybe' a) +-- 'preuse' :: 'MonadState' s m => 'Iso'' s a -> m ('Maybe' a) +-- 'preuse' :: 'MonadState' s m => 'Traversal'' s a -> m ('Maybe' a) +-- @ +preuse :: MonadState s m => Getting (First a) s a -> m (Maybe a) +preuse l = gets (preview l) +{-# INLINE preuse #-} + +-- | Retrieve the first index and value targeted by an 'IndexedFold' or 'IndexedTraversal' (or 'Just' the index +-- and result from an 'IndexedGetter' or 'IndexedLens') into the current state. +-- +-- @ +-- 'ipreuse' = 'use' '.' 'ipre' +-- @ +-- +-- @ +-- 'ipreuse' :: 'MonadState' s m => 'IndexedGetter' i s a -> m ('Maybe' (i, a)) +-- 'ipreuse' :: 'MonadState' s m => 'IndexedFold' i s a -> m ('Maybe' (i, a)) +-- 'ipreuse' :: 'MonadState' s m => 'IndexedLens'' i s a -> m ('Maybe' (i, a)) +-- 'ipreuse' :: 'MonadState' s m => 'IndexedTraversal'' i s a -> m ('Maybe' (i, a)) +-- @ +ipreuse :: MonadState s m => IndexedGetting i (First (i, a)) s a -> m (Maybe (i, a)) +ipreuse l = gets (ipreview l) +{-# INLINE ipreuse #-} + +-- | Retrieve a function of the first value targeted by a 'Fold' or +-- 'Traversal' (or 'Just' the result from a 'Getter' or 'Lens') into the current state. +-- +-- @ +-- 'preuses' = 'uses' '.' 'pre' +-- @ +-- +-- @ +-- 'preuses' :: 'MonadState' s m => 'Getter' s a -> (a -> r) -> m ('Maybe' r) +-- 'preuses' :: 'MonadState' s m => 'Fold' s a -> (a -> r) -> m ('Maybe' r) +-- 'preuses' :: 'MonadState' s m => 'Lens'' s a -> (a -> r) -> m ('Maybe' r) +-- 'preuses' :: 'MonadState' s m => 'Iso'' s a -> (a -> r) -> m ('Maybe' r) +-- 'preuses' :: 'MonadState' s m => 'Traversal'' s a -> (a -> r) -> m ('Maybe' r) +-- @ +preuses :: MonadState s m => Getting (First r) s a -> (a -> r) -> m (Maybe r) +preuses l f = gets (previews l f) +{-# INLINE preuses #-} + +-- | Retrieve a function of the first index and value targeted by an 'IndexedFold' or +-- 'IndexedTraversal' (or a function of 'Just' the index and result from an 'IndexedGetter' +-- or 'IndexedLens') into the current state. +-- +-- @ +-- 'ipreuses' = 'uses' '.' 'ipre' +-- @ +-- +-- @ +-- 'ipreuses' :: 'MonadState' s m => 'IndexedGetter' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreuses' :: 'MonadState' s m => 'IndexedFold' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreuses' :: 'MonadState' s m => 'IndexedLens'' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- 'ipreuses' :: 'MonadState' s m => 'IndexedTraversal'' i s a -> (i -> a -> r) -> m ('Maybe' r) +-- @ +ipreuses :: MonadState s m => IndexedGetting i (First r) s a -> (i -> a -> r) -> m (Maybe r) +ipreuses l f = gets (ipreviews l f) +{-# INLINE ipreuses #-} + +------------------------------------------------------------------------------ +-- Profunctors +------------------------------------------------------------------------------ + + +-- | This allows you to 'Control.Traversable.traverse' the elements of a pretty much any 'LensLike' construction in the opposite order. +-- +-- This will preserve indexes on 'Indexed' types and will give you the elements of a (finite) 'Fold' or 'Traversal' in the opposite order. +-- +-- This has no practical impact on a 'Getter', 'Setter', 'Lens' or 'Iso'. +-- +-- /NB:/ To write back through an 'Iso', you want to use 'Control.Lens.Isomorphic.from'. +-- Similarly, to write back through an 'Prism', you want to use 'Control.Lens.Review.re'. +backwards :: (Profunctor p, Profunctor q) => Optical p q (Backwards f) s t a b -> Optical p q f s t a b +backwards l f = forwards #. l (Backwards #. f) +{-# INLINE backwards #-} + +------------------------------------------------------------------------------ +-- Indexed Folds +------------------------------------------------------------------------------ + +-- | Fold an 'IndexedFold' or 'IndexedTraversal' by mapping indices and values to an arbitrary 'Monoid' with access +-- to the @i@. +-- +-- When you don't need access to the index then 'foldMapOf' is more flexible in what it accepts. +-- +-- @ +-- 'foldMapOf' l ≡ 'ifoldMapOf' l '.' 'const' +-- @ +-- +-- @ +-- 'ifoldMapOf' :: 'IndexedGetter' i s a -> (i -> a -> m) -> s -> m +-- 'ifoldMapOf' :: 'Monoid' m => 'IndexedFold' i s a -> (i -> a -> m) -> s -> m +-- 'ifoldMapOf' :: 'IndexedLens'' i s a -> (i -> a -> m) -> s -> m +-- 'ifoldMapOf' :: 'Monoid' m => 'IndexedTraversal'' i s a -> (i -> a -> m) -> s -> m +-- @ +-- +ifoldMapOf :: IndexedGetting i m s a -> (i -> a -> m) -> s -> m +ifoldMapOf = coerce +{-# INLINE ifoldMapOf #-} + +-- | Right-associative fold of parts of a structure that are viewed through an 'IndexedFold' or 'IndexedTraversal' with +-- access to the @i@. +-- +-- When you don't need access to the index then 'foldrOf' is more flexible in what it accepts. +-- +-- @ +-- 'foldrOf' l ≡ 'ifoldrOf' l '.' 'const' +-- @ +-- +-- @ +-- 'ifoldrOf' :: 'IndexedGetter' i s a -> (i -> a -> r -> r) -> r -> s -> r +-- 'ifoldrOf' :: 'IndexedFold' i s a -> (i -> a -> r -> r) -> r -> s -> r +-- 'ifoldrOf' :: 'IndexedLens'' i s a -> (i -> a -> r -> r) -> r -> s -> r +-- 'ifoldrOf' :: 'IndexedTraversal'' i s a -> (i -> a -> r -> r) -> r -> s -> r +-- @ +ifoldrOf :: IndexedGetting i (Endo r) s a -> (i -> a -> r -> r) -> r -> s -> r +ifoldrOf l f z = flip appEndo z . getConst #. l (Const #. Endo #. Indexed f) +{-# INLINE ifoldrOf #-} + +-- | Left-associative fold of the parts of a structure that are viewed through an 'IndexedFold' or 'IndexedTraversal' with +-- access to the @i@. +-- +-- When you don't need access to the index then 'foldlOf' is more flexible in what it accepts. +-- +-- @ +-- 'foldlOf' l ≡ 'ifoldlOf' l '.' 'const' +-- @ +-- +-- @ +-- 'ifoldlOf' :: 'IndexedGetter' i s a -> (i -> r -> a -> r) -> r -> s -> r +-- 'ifoldlOf' :: 'IndexedFold' i s a -> (i -> r -> a -> r) -> r -> s -> r +-- 'ifoldlOf' :: 'IndexedLens'' i s a -> (i -> r -> a -> r) -> r -> s -> r +-- 'ifoldlOf' :: 'IndexedTraversal'' i s a -> (i -> r -> a -> r) -> r -> s -> r +-- @ +ifoldlOf :: IndexedGetting i (Dual (Endo r)) s a -> (i -> r -> a -> r) -> r -> s -> r +ifoldlOf l f z = (flip appEndo z .# getDual) `rmap` ifoldMapOf l (\i -> Dual #. Endo #. flip (f i)) +{-# INLINE ifoldlOf #-} + +-- | Return whether or not any element viewed through an 'IndexedFold' or 'IndexedTraversal' +-- satisfy a predicate, with access to the @i@. +-- +-- When you don't need access to the index then 'anyOf' is more flexible in what it accepts. +-- +-- @ +-- 'anyOf' l ≡ 'ianyOf' l '.' 'const' +-- @ +-- +-- @ +-- 'ianyOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'ianyOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'ianyOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'ianyOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- @ +ianyOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool +ianyOf = coerce +{-# INLINE ianyOf #-} + +-- | Return whether or not all elements viewed through an 'IndexedFold' or 'IndexedTraversal' +-- satisfy a predicate, with access to the @i@. +-- +-- When you don't need access to the index then 'allOf' is more flexible in what it accepts. +-- +-- @ +-- 'allOf' l ≡ 'iallOf' l '.' 'const' +-- @ +-- +-- @ +-- 'iallOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'iallOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'iallOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'iallOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- @ +iallOf :: IndexedGetting i All s a -> (i -> a -> Bool) -> s -> Bool +iallOf = coerce +{-# INLINE iallOf #-} + +-- | Return whether or not none of the elements viewed through an 'IndexedFold' or 'IndexedTraversal' +-- satisfy a predicate, with access to the @i@. +-- +-- When you don't need access to the index then 'noneOf' is more flexible in what it accepts. +-- +-- @ +-- 'noneOf' l ≡ 'inoneOf' l '.' 'const' +-- @ +-- +-- @ +-- 'inoneOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'inoneOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'inoneOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- 'inoneOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Bool' +-- @ +inoneOf :: IndexedGetting i Any s a -> (i -> a -> Bool) -> s -> Bool +inoneOf l f = not . ianyOf l f +{-# INLINE inoneOf #-} + +-- | Traverse the targets of an 'IndexedFold' or 'IndexedTraversal' with access to the @i@, discarding the results. +-- +-- When you don't need access to the index then 'traverseOf_' is more flexible in what it accepts. +-- +-- @ +-- 'traverseOf_' l ≡ 'Control.Lens.Traversal.itraverseOf' l '.' 'const' +-- @ +-- +-- @ +-- 'itraverseOf_' :: 'Functor' f => 'IndexedGetter' i s a -> (i -> a -> f r) -> s -> f () +-- 'itraverseOf_' :: 'Applicative' f => 'IndexedFold' i s a -> (i -> a -> f r) -> s -> f () +-- 'itraverseOf_' :: 'Functor' f => 'IndexedLens'' i s a -> (i -> a -> f r) -> s -> f () +-- 'itraverseOf_' :: 'Applicative' f => 'IndexedTraversal'' i s a -> (i -> a -> f r) -> s -> f () +-- @ +itraverseOf_ :: Functor f => IndexedGetting i (Traversed r f) s a -> (i -> a -> f r) -> s -> f () +itraverseOf_ l f = void . getTraversed #. getConst #. l (Const #. Traversed #. Indexed f) +{-# INLINE itraverseOf_ #-} + +-- | Traverse the targets of an 'IndexedFold' or 'IndexedTraversal' with access to the index, discarding the results +-- (with the arguments flipped). +-- +-- @ +-- 'iforOf_' ≡ 'flip' '.' 'itraverseOf_' +-- @ +-- +-- When you don't need access to the index then 'forOf_' is more flexible in what it accepts. +-- +-- @ +-- 'forOf_' l a ≡ 'iforOf_' l a '.' 'const' +-- @ +-- +-- @ +-- 'iforOf_' :: 'Functor' f => 'IndexedGetter' i s a -> s -> (i -> a -> f r) -> f () +-- 'iforOf_' :: 'Applicative' f => 'IndexedFold' i s a -> s -> (i -> a -> f r) -> f () +-- 'iforOf_' :: 'Functor' f => 'IndexedLens'' i s a -> s -> (i -> a -> f r) -> f () +-- 'iforOf_' :: 'Applicative' f => 'IndexedTraversal'' i s a -> s -> (i -> a -> f r) -> f () +-- @ +iforOf_ :: Functor f => IndexedGetting i (Traversed r f) s a -> s -> (i -> a -> f r) -> f () +iforOf_ = flip . itraverseOf_ +{-# INLINE iforOf_ #-} + +-- | Run monadic actions for each target of an 'IndexedFold' or 'IndexedTraversal' with access to the index, +-- discarding the results. +-- +-- When you don't need access to the index then 'mapMOf_' is more flexible in what it accepts. +-- +-- @ +-- 'mapMOf_' l ≡ 'Control.Lens.Setter.imapMOf' l '.' 'const' +-- @ +-- +-- @ +-- 'imapMOf_' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> m r) -> s -> m () +-- 'imapMOf_' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> m r) -> s -> m () +-- 'imapMOf_' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> m r) -> s -> m () +-- 'imapMOf_' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m r) -> s -> m () +-- @ +imapMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s a -> (i -> a -> m r) -> s -> m () +imapMOf_ l f = liftM skip . getSequenced #. getConst #. l (Const #. Sequenced #. Indexed f) +{-# INLINE imapMOf_ #-} + +-- | Run monadic actions for each target of an 'IndexedFold' or 'IndexedTraversal' with access to the index, +-- discarding the results (with the arguments flipped). +-- +-- @ +-- 'iforMOf_' ≡ 'flip' '.' 'imapMOf_' +-- @ +-- +-- When you don't need access to the index then 'forMOf_' is more flexible in what it accepts. +-- +-- @ +-- 'forMOf_' l a ≡ 'Control.Lens.Traversal.iforMOf' l a '.' 'const' +-- @ +-- +-- @ +-- 'iforMOf_' :: 'Monad' m => 'IndexedGetter' i s a -> s -> (i -> a -> m r) -> m () +-- 'iforMOf_' :: 'Monad' m => 'IndexedFold' i s a -> s -> (i -> a -> m r) -> m () +-- 'iforMOf_' :: 'Monad' m => 'IndexedLens'' i s a -> s -> (i -> a -> m r) -> m () +-- 'iforMOf_' :: 'Monad' m => 'IndexedTraversal'' i s a -> s -> (i -> a -> m r) -> m () +-- @ +iforMOf_ :: Monad m => IndexedGetting i (Sequenced r m) s a -> s -> (i -> a -> m r) -> m () +iforMOf_ = flip . imapMOf_ +{-# INLINE iforMOf_ #-} + +-- | Concatenate the results of a function of the elements of an 'IndexedFold' or 'IndexedTraversal' +-- with access to the index. +-- +-- When you don't need access to the index then 'concatMapOf' is more flexible in what it accepts. +-- +-- @ +-- 'concatMapOf' l ≡ 'iconcatMapOf' l '.' 'const' +-- 'iconcatMapOf' ≡ 'ifoldMapOf' +-- @ +-- +-- @ +-- 'iconcatMapOf' :: 'IndexedGetter' i s a -> (i -> a -> [r]) -> s -> [r] +-- 'iconcatMapOf' :: 'IndexedFold' i s a -> (i -> a -> [r]) -> s -> [r] +-- 'iconcatMapOf' :: 'IndexedLens'' i s a -> (i -> a -> [r]) -> s -> [r] +-- 'iconcatMapOf' :: 'IndexedTraversal'' i s a -> (i -> a -> [r]) -> s -> [r] +-- @ +iconcatMapOf :: IndexedGetting i [r] s a -> (i -> a -> [r]) -> s -> [r] +iconcatMapOf = ifoldMapOf +{-# INLINE iconcatMapOf #-} + +-- | The 'ifindOf' function takes an 'IndexedFold' or 'IndexedTraversal', a predicate that is also +-- supplied the index, a structure and returns the left-most element of the structure +-- matching the predicate, or 'Nothing' if there is no such element. +-- +-- When you don't need access to the index then 'findOf' is more flexible in what it accepts. +-- +-- @ +-- 'findOf' l ≡ 'ifindOf' l '.' 'const' +-- @ +-- +-- @ +-- 'ifindOf' :: 'IndexedGetter' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a +-- 'ifindOf' :: 'IndexedFold' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a +-- 'ifindOf' :: 'IndexedLens'' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a +-- 'ifindOf' :: 'IndexedTraversal'' i s a -> (i -> a -> 'Bool') -> s -> 'Maybe' a +-- @ +ifindOf :: IndexedGetting i (Endo (Maybe a)) s a -> (i -> a -> Bool) -> s -> Maybe a +ifindOf l f = ifoldrOf l (\i a y -> if f i a then Just a else y) Nothing +{-# INLINE ifindOf #-} + +-- | The 'ifindMOf' function takes an 'IndexedFold' or 'IndexedTraversal', a monadic predicate that is also +-- supplied the index, a structure and returns in the monad the left-most element of the structure +-- matching the predicate, or 'Nothing' if there is no such element. +-- +-- When you don't need access to the index then 'findMOf' is more flexible in what it accepts. +-- +-- @ +-- 'findMOf' l ≡ 'ifindMOf' l '.' 'const' +-- @ +-- +-- @ +-- 'ifindMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) +-- 'ifindMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) +-- 'ifindMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) +-- 'ifindMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> m 'Bool') -> s -> m ('Maybe' a) +-- @ +ifindMOf :: Monad m => IndexedGetting i (Endo (m (Maybe a))) s a -> (i -> a -> m Bool) -> s -> m (Maybe a) +ifindMOf l f = ifoldrOf l (\i a y -> f i a >>= \r -> if r then return (Just a) else y) $ return Nothing +{-# INLINE ifindMOf #-} + +-- | /Strictly/ fold right over the elements of a structure with an index. +-- +-- When you don't need access to the index then 'foldrOf'' is more flexible in what it accepts. +-- +-- @ +-- 'foldrOf'' l ≡ 'ifoldrOf'' l '.' 'const' +-- @ +-- +-- @ +-- 'ifoldrOf'' :: 'IndexedGetter' i s a -> (i -> a -> r -> r) -> r -> s -> r +-- 'ifoldrOf'' :: 'IndexedFold' i s a -> (i -> a -> r -> r) -> r -> s -> r +-- 'ifoldrOf'' :: 'IndexedLens'' i s a -> (i -> a -> r -> r) -> r -> s -> r +-- 'ifoldrOf'' :: 'IndexedTraversal'' i s a -> (i -> a -> r -> r) -> r -> s -> r +-- @ +ifoldrOf' :: IndexedGetting i (Dual (Endo (r -> r))) s a -> (i -> a -> r -> r) -> r -> s -> r +ifoldrOf' l f z0 xs = ifoldlOf l f' id xs z0 + where f' i k x z = k $! f i x z +{-# INLINE ifoldrOf' #-} + +-- | Fold over the elements of a structure with an index, associating to the left, but /strictly/. +-- +-- When you don't need access to the index then 'foldlOf'' is more flexible in what it accepts. +-- +-- @ +-- 'foldlOf'' l ≡ 'ifoldlOf'' l '.' 'const' +-- @ +-- +-- @ +-- 'ifoldlOf'' :: 'IndexedGetter' i s a -> (i -> r -> a -> r) -> r -> s -> r +-- 'ifoldlOf'' :: 'IndexedFold' i s a -> (i -> r -> a -> r) -> r -> s -> r +-- 'ifoldlOf'' :: 'IndexedLens'' i s a -> (i -> r -> a -> r) -> r -> s -> r +-- 'ifoldlOf'' :: 'IndexedTraversal'' i s a -> (i -> r -> a -> r) -> r -> s -> r +-- @ +ifoldlOf' :: IndexedGetting i (Endo (r -> r)) s a -> (i -> r -> a -> r) -> r -> s -> r +ifoldlOf' l f z0 xs = ifoldrOf l f' id xs z0 + where f' i x k z = k $! f i z x +{-# INLINE ifoldlOf' #-} + +-- | Monadic fold right over the elements of a structure with an index. +-- +-- When you don't need access to the index then 'foldrMOf' is more flexible in what it accepts. +-- +-- @ +-- 'foldrMOf' l ≡ 'ifoldrMOf' l '.' 'const' +-- @ +-- +-- @ +-- 'ifoldrMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> a -> r -> m r) -> r -> s -> m r +-- 'ifoldrMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> a -> r -> m r) -> r -> s -> m r +-- 'ifoldrMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> a -> r -> m r) -> r -> s -> m r +-- 'ifoldrMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> a -> r -> m r) -> r -> s -> m r +-- @ +ifoldrMOf :: Monad m => IndexedGetting i (Dual (Endo (r -> m r))) s a -> (i -> a -> r -> m r) -> r -> s -> m r +ifoldrMOf l f z0 xs = ifoldlOf l f' return xs z0 + where f' i k x z = f i x z >>= k +{-# INLINE ifoldrMOf #-} + +-- | Monadic fold over the elements of a structure with an index, associating to the left. +-- +-- When you don't need access to the index then 'foldlMOf' is more flexible in what it accepts. +-- +-- @ +-- 'foldlMOf' l ≡ 'ifoldlMOf' l '.' 'const' +-- @ +-- +-- @ +-- 'ifoldlMOf' :: 'Monad' m => 'IndexedGetter' i s a -> (i -> r -> a -> m r) -> r -> s -> m r +-- 'ifoldlMOf' :: 'Monad' m => 'IndexedFold' i s a -> (i -> r -> a -> m r) -> r -> s -> m r +-- 'ifoldlMOf' :: 'Monad' m => 'IndexedLens'' i s a -> (i -> r -> a -> m r) -> r -> s -> m r +-- 'ifoldlMOf' :: 'Monad' m => 'IndexedTraversal'' i s a -> (i -> r -> a -> m r) -> r -> s -> m r +-- @ +ifoldlMOf :: Monad m => IndexedGetting i (Endo (r -> m r)) s a -> (i -> r -> a -> m r) -> r -> s -> m r +ifoldlMOf l f z0 xs = ifoldrOf l f' return xs z0 + where f' i x k z = f i z x >>= k +{-# INLINE ifoldlMOf #-} + +-- | Extract the key-value pairs from a structure. +-- +-- When you don't need access to the indices in the result, then 'toListOf' is more flexible in what it accepts. +-- +-- @ +-- 'toListOf' l ≡ 'map' 'snd' '.' 'itoListOf' l +-- @ +-- +-- @ +-- 'itoListOf' :: 'IndexedGetter' i s a -> s -> [(i,a)] +-- 'itoListOf' :: 'IndexedFold' i s a -> s -> [(i,a)] +-- 'itoListOf' :: 'IndexedLens'' i s a -> s -> [(i,a)] +-- 'itoListOf' :: 'IndexedTraversal'' i s a -> s -> [(i,a)] +-- @ +itoListOf :: IndexedGetting i (Endo [(i,a)]) s a -> s -> [(i,a)] +itoListOf l = ifoldrOf l (\i a -> ((i,a):)) [] +{-# INLINE itoListOf #-} + +-- | An infix version of 'itoListOf'. + +-- @ +-- ('^@..') :: s -> 'IndexedGetter' i s a -> [(i,a)] +-- ('^@..') :: s -> 'IndexedFold' i s a -> [(i,a)] +-- ('^@..') :: s -> 'IndexedLens'' i s a -> [(i,a)] +-- ('^@..') :: s -> 'IndexedTraversal'' i s a -> [(i,a)] +-- @ +(^@..) :: s -> IndexedGetting i (Endo [(i,a)]) s a -> [(i,a)] +s ^@.. l = ifoldrOf l (\i a -> ((i,a):)) [] s +{-# INLINE (^@..) #-} + +-- | Perform a safe 'head' (with index) of an 'IndexedFold' or 'IndexedTraversal' or retrieve 'Just' the index and result +-- from an 'IndexedGetter' or 'IndexedLens'. +-- +-- When using a 'IndexedTraversal' as a partial 'IndexedLens', or an 'IndexedFold' as a partial 'IndexedGetter' this can be a convenient +-- way to extract the optional value. +-- +-- @ +-- ('^@?') :: s -> 'IndexedGetter' i s a -> 'Maybe' (i, a) +-- ('^@?') :: s -> 'IndexedFold' i s a -> 'Maybe' (i, a) +-- ('^@?') :: s -> 'IndexedLens'' i s a -> 'Maybe' (i, a) +-- ('^@?') :: s -> 'IndexedTraversal'' i s a -> 'Maybe' (i, a) +-- @ +(^@?) :: s -> IndexedGetting i (Endo (Maybe (i, a))) s a -> Maybe (i, a) +s ^@? l = ifoldrOf l (\i x _ -> Just (i,x)) Nothing s +{-# INLINE (^@?) #-} + +-- | Perform an *UNSAFE* 'head' (with index) of an 'IndexedFold' or 'IndexedTraversal' assuming that it is there. +-- +-- @ +-- ('^@?!') :: s -> 'IndexedGetter' i s a -> (i, a) +-- ('^@?!') :: s -> 'IndexedFold' i s a -> (i, a) +-- ('^@?!') :: s -> 'IndexedLens'' i s a -> (i, a) +-- ('^@?!') :: s -> 'IndexedTraversal'' i s a -> (i, a) +-- @ +(^@?!) :: HasCallStack => s -> IndexedGetting i (Endo (i, a)) s a -> (i, a) +s ^@?! l = ifoldrOf l (\i x _ -> (i,x)) (error "(^@?!): empty Fold") s +{-# INLINE (^@?!) #-} + +-- | Retrieve the index of the first value targeted by a 'IndexedFold' or 'IndexedTraversal' which is equal to a given value. +-- +-- @ +-- 'Data.List.elemIndex' ≡ 'elemIndexOf' 'folded' +-- @ +-- +-- @ +-- 'elemIndexOf' :: 'Eq' a => 'IndexedFold' i s a -> a -> s -> 'Maybe' i +-- 'elemIndexOf' :: 'Eq' a => 'IndexedTraversal'' i s a -> a -> s -> 'Maybe' i +-- @ +elemIndexOf :: Eq a => IndexedGetting i (First i) s a -> a -> s -> Maybe i +elemIndexOf l a = findIndexOf l (a ==) +{-# INLINE elemIndexOf #-} + +-- | Retrieve the indices of the values targeted by a 'IndexedFold' or 'IndexedTraversal' which are equal to a given value. +-- +-- @ +-- 'Data.List.elemIndices' ≡ 'elemIndicesOf' 'folded' +-- @ +-- +-- @ +-- 'elemIndicesOf' :: 'Eq' a => 'IndexedFold' i s a -> a -> s -> [i] +-- 'elemIndicesOf' :: 'Eq' a => 'IndexedTraversal'' i s a -> a -> s -> [i] +-- @ +elemIndicesOf :: Eq a => IndexedGetting i (Endo [i]) s a -> a -> s -> [i] +elemIndicesOf l a = findIndicesOf l (a ==) +{-# INLINE elemIndicesOf #-} + +-- | Retrieve the index of the first value targeted by a 'IndexedFold' or 'IndexedTraversal' which satisfies a predicate. +-- +-- @ +-- 'Data.List.findIndex' ≡ 'findIndexOf' 'folded' +-- @ +-- +-- @ +-- 'findIndexOf' :: 'IndexedFold' i s a -> (a -> 'Bool') -> s -> 'Maybe' i +-- 'findIndexOf' :: 'IndexedTraversal'' i s a -> (a -> 'Bool') -> s -> 'Maybe' i +-- @ +findIndexOf :: IndexedGetting i (First i) s a -> (a -> Bool) -> s -> Maybe i +findIndexOf l p = preview (l . filtered p . asIndex) +{-# INLINE findIndexOf #-} + +-- | Retrieve the indices of the values targeted by a 'IndexedFold' or 'IndexedTraversal' which satisfy a predicate. +-- +-- @ +-- 'Data.List.findIndices' ≡ 'findIndicesOf' 'folded' +-- @ +-- +-- @ +-- 'findIndicesOf' :: 'IndexedFold' i s a -> (a -> 'Bool') -> s -> [i] +-- 'findIndicesOf' :: 'IndexedTraversal'' i s a -> (a -> 'Bool') -> s -> [i] +-- @ +findIndicesOf :: IndexedGetting i (Endo [i]) s a -> (a -> Bool) -> s -> [i] +findIndicesOf l p = toListOf (l . filtered p . asIndex) +{-# INLINE findIndicesOf #-} + +------------------------------------------------------------------------------- +-- Converting to Folds +------------------------------------------------------------------------------- + +-- | Filter an 'IndexedFold' or 'IndexedGetter', obtaining an 'IndexedFold'. +-- +-- >>> [0,0,0,5,5,5]^..traversed.ifiltered (\i a -> i <= a) +-- [0,5,5,5] +-- +-- Compose with 'ifiltered' to filter another 'IndexedLens', 'IndexedIso', 'IndexedGetter', 'IndexedFold' (or 'IndexedTraversal') with +-- access to both the value and the index. +-- +-- Note: As with 'filtered', this is /not/ a legal 'IndexedTraversal', unless you are very careful not to invalidate the predicate on the target! +ifiltered :: (Indexable i p, Applicative f) => (i -> a -> Bool) -> Optical' p (Indexed i) f a a +ifiltered p f = Indexed $ \i a -> if p i a then indexed f i a else pure a +{-# INLINE ifiltered #-} + +-- | Obtain an 'IndexedFold' by taking elements from another +-- 'IndexedFold', 'IndexedLens', 'IndexedGetter' or 'IndexedTraversal' while a predicate holds. +-- +-- @ +-- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a +-- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedTraversal'' i s a -> 'IndexedFold' i s a +-- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a +-- 'itakingWhile' :: (i -> a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a +-- @ +-- +-- Note: Applying 'itakingWhile' to an 'IndexedLens' or 'IndexedTraversal' will still allow you to use it as a +-- pseudo-'IndexedTraversal', but if you change the value of any target to one where the predicate returns +-- 'False', then you will break the 'Traversal' laws and 'Traversal' fusion will no longer be sound. +itakingWhile :: (Indexable i p, Profunctor q, Contravariant f, Applicative f) + => (i -> a -> Bool) + -> Optical' (Indexed i) q (Const (Endo (f s))) s a + -> Optical' p q f s a +itakingWhile p l f = (flip appEndo noEffect .# getConst) `rmap` l g where + g = Indexed $ \i a -> Const . Endo $ if p i a then (indexed f i a *>) else const noEffect +{-# INLINE itakingWhile #-} + +-- | Obtain an 'IndexedFold' by dropping elements from another 'IndexedFold', 'IndexedLens', 'IndexedGetter' or 'IndexedTraversal' while a predicate holds. +-- +-- @ +-- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedFold' i s a -> 'IndexedFold' i s a +-- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedTraversal'' i s a -> 'IndexedFold' i s a -- see notes +-- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedLens'' i s a -> 'IndexedFold' i s a -- see notes +-- 'idroppingWhile' :: (i -> a -> 'Bool') -> 'IndexedGetter' i s a -> 'IndexedFold' i s a +-- @ +-- +-- Note: As with `droppingWhile` applying 'idroppingWhile' to an 'IndexedLens' or 'IndexedTraversal' will still +-- allow you to use it as a pseudo-'IndexedTraversal', but if you change the value of the first target to one +-- where the predicate returns 'True', then you will break the 'Traversal' laws and 'Traversal' fusion will +-- no longer be sound. +idroppingWhile :: (Indexable i p, Profunctor q, Applicative f) + => (i -> a -> Bool) + -> Optical (Indexed i) q (Compose (State Bool) f) s t a a + -> Optical p q f s t a a +idroppingWhile p l f = (flip evalState True .# getCompose) `rmap` l g where + g = Indexed $ \ i a -> Compose $ state $ \b -> let + b' = b && p i a + in (if b' then pure a else indexed f i a, b') +{-# INLINE idroppingWhile #-} + +------------------------------------------------------------------------------ +-- Misc. +------------------------------------------------------------------------------ + +skip :: a -> () +skip _ = () +{-# INLINE skip #-} + +noEffect = undefined + +collect = undefined + +apDefault = undefined + +swap = undefined diff --git a/testsuite/tests/haddock/perf/Makefile b/testsuite/tests/haddock/perf/Makefile new file mode 100644 index 0000000000..dfd63d7127 --- /dev/null +++ b/testsuite/tests/haddock/perf/Makefile @@ -0,0 +1,15 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# We accept a 5% increase in parser allocations due to -haddock +haddock_parser_perf : + WithHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fforce-recomp -Wno-all -ddump-timings -haddock -O0 Fold.hs 2>/dev/null | grep Parser | grep -o 'alloc=[0-9]\+' | cut -c7- ) ; \ + WithoutHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fforce-recomp -Wno-all -ddump-timings -O0 Fold.hs 2>/dev/null | grep Parser | grep -o 'alloc=[0-9]\+' | cut -c7- ) ; \ + awk "BEGIN { ratio = ($$WithHaddock / $$WithoutHaddock); if (ratio > 1.05) {print \"-haddock allocation ratio too high:\", ratio; exit 1} else {exit 0} }" + +# Similarly for the renamer +haddock_renamer_perf : + WithoutHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fforce-recomp -Wno-all -ddump-timings -O0 Fold.hs 2>/dev/null | grep Renamer | grep -o 'alloc=[0-9]\+' | cut -c7- ) ; \ + WithHaddock=$(shell '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fforce-recomp -Wno-all -ddump-timings -haddock -O0 Fold.hs 2>/dev/null | grep Renamer | grep -o 'alloc=[0-9]\+' | cut -c7- ) ; \ + awk "BEGIN { ratio = ($$WithHaddock / $$WithoutHaddock); if (ratio > 1.05) {print \"-haddock allocation ratio too high:\", ratio; exit 1} else {exit 0} }" diff --git a/testsuite/tests/haddock/perf/all.T b/testsuite/tests/haddock/perf/all.T new file mode 100644 index 0000000000..63e01cd28e --- /dev/null +++ b/testsuite/tests/haddock/perf/all.T @@ -0,0 +1,2 @@ +test('haddock_parser_perf', [extra_files(['Fold.hs'])], makefile_test, []) +test('haddock_renamer_perf', [extra_files(['Fold.hs'])], makefile_test, []) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr index 5fe63362b1..e31ff87c33 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr @@ -7,12 +7,15 @@ newtype DWrapper a = DWrap a instance D (DWrapper a) data Foo = Foo - deriving Eq " Documenting a single type" + deriving -- | Documenting a single type + Eq data Bar = Bar - deriving (Eq " Documenting one of multiple types", Ord) - deriving anyclass (forall a. C a " Documenting forall type ") - deriving D " Documenting deriving via " via DWrapper Bar + deriving (-- | Documenting one of multiple types + Eq, + Ord) + deriving anyclass (forall a. C a {-^ Documenting forall type -}) + deriving D {-^ Documenting deriving via -} via DWrapper Bar <document comment> deriving instance Read Bar diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr index 8a12344e36..5231bb1905 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T15206.stderr @@ -1,6 +1,10 @@ ==================== Parser ==================== module T15206 where -data Point = " a 2D point" Point !Int " x coord" !Int " y coord" +data Point + = -- | a 2D point + Point -- | x coord + !Int -- | y coord + !Int diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr index 9bf18f0f9b..bea795d887 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T16585.stderr @@ -1,6 +1,10 @@ ==================== Parser ==================== module T16585 where -data F a where X :: !Int " comment" -> F Int +data F a + where + X :: -- | comment + !Int -> + F Int diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index 28393796b1..781d006b54 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -156,8 +156,16 @@ {OccName: Int})))) (L { T17544.hs:7:5-23 } - (HsDocString - " comment on Int"))))))))))] + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringPrevious) + (:| + (L + { T17544.hs:7:9-23 } + (HsDocStringChunk + " comment on Int")) + [])) + []))))))))))] {Bag(LocatedA (HsBind GhcPs)): []} [] @@ -286,8 +294,18 @@ [(L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:11:3-20 }) (DocCommentPrev - (HsDocString - " comment on f2")))]))) + (L + { T17544.hs:11:3-20 } + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringPrevious) + (:| + (L + { T17544.hs:11:7-20 } + (HsDocStringChunk + " comment on f2")) + [])) + []))))]))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -414,8 +432,18 @@ (DocD (NoExtField) (DocCommentPrev - (HsDocString - " comment on C3")))) + (L + { T17544.hs:15:1-18 } + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringPrevious) + (:| + (L + { T17544.hs:15:5-18 } + (HsDocStringChunk + " comment on C3")) + [])) + []))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -2182,8 +2210,18 @@ (DocD (NoExtField) (DocCommentPrev - (HsDocString - " comment on class instance C10 Int"))))] + (L + { T17544.hs:56:1-38 } + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringPrevious) + (:| + (L + { T17544.hs:56:5-38 } + (HsDocStringChunk + " comment on class instance C10 Int")) + [])) + [])))))] (Nothing) (Nothing))) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr index 41346ee437..63fe2c10d5 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -107,8 +107,16 @@ (Just (L { T17544_kw.hs:15:10-35 } - (HsDocString - " Bad comment for MkFoo")))))] + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringNext) + (:| + (L + { T17544_kw.hs:15:14-35 } + (HsDocStringChunk + " Bad comment for MkFoo")) + [])) + [])))))] [])))) ,(L (SrcSpanAnn (EpAnn @@ -210,8 +218,16 @@ (Just (L { T17544_kw.hs:18:13-38 } - (HsDocString - " Bad comment for MkBar")))))] + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringNext) + (:| + (L + { T17544_kw.hs:18:17-38 } + (HsDocStringChunk + " Bad comment for MkBar")) + [])) + [])))))] [])))) ,(L (SrcSpanAnn (EpAnn @@ -306,13 +322,31 @@ [(L (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:22:5-34 }) (DocCommentNext - (HsDocString - " Bad comment for clsmethod")))])))] + (L + { T17544_kw.hs:22:5-34 } + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringNext) + (:| + (L + { T17544_kw.hs:22:9-34 } + (HsDocStringChunk + " Bad comment for clsmethod")) + [])) + []))))])))] (Nothing) (Just (L { T17544_kw.hs:12:3-33 } - (HsDocString - " Bad comment for the module"))))) + (WithHsDocIdentifiers + (MultiLineDocString + (HsDocStringNext) + (:| + (L + { T17544_kw.hs:12:7-33 } + (HsDocStringChunk + " Bad comment for the module")) + [])) + []))))) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17652.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17652.stderr index e1e5cf5c25..67d4a644c2 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17652.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17652.stderr @@ -1,6 +1,9 @@ ==================== Parser ==================== module T17652 where -data X = B !Int " x" String " y" +data X + = B -- | x + !Int -- | y + String diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T8944.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T8944.stderr index 6a7e12e763..2591afcbce 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T8944.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T8944.stderr @@ -3,7 +3,9 @@ module T8944 where import Data.Maybe () import Data.Functor () -data F = F () " Comment for the first argument" () +data F + = F -- | Comment for the first argument + () () diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr index f55f8afab1..fd5c7ff2bf 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA014.stderr @@ -1,6 +1,6 @@ ==================== Parser ==================== -" a header" +-- | a header module HeaderTest where <document comment> x = 0 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr index 15adf3e54e..ef37d0897c 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA015.stderr @@ -1,6 +1,6 @@ ==================== Parser ==================== -" a header" +-- | a header module HeaderTest where <document comment> x = 0 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr index e9ccec44a0..d996377094 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA016.stderr @@ -1,6 +1,6 @@ ==================== Parser ==================== -"Module description" +-- |Module description module A where diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr index 357f7540e2..fe5ac90d90 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA018.stderr @@ -1,6 +1,6 @@ ==================== Parser ==================== -" module header bla bla " +-- | module header bla bla module A where diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr index c7a34730d9..ca316bc8b8 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA019.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module A ( - " bla bla", " blabla " + bla bla, blabla ) where diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr index 660b28036e..2aaa3eba98 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA020.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module A ( - " bla bla", " blabla ", x, <IEGroup: 2>, " qweljqwelkqjwelqjkq" + bla bla, blabla , x, <IEGroup: 2>, qweljqwelkqjwelqjkq ) where x = True diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr index befbee45f9..162c403b84 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA021.stderr @@ -1,8 +1,8 @@ ==================== Parser ==================== module A ( - " bla bla", " blabla ", x, <IEGroup: 2>, " qweljqwelkqjwelqjkq", y, - " dkashdakj", z, <IEGroup: 1> + bla bla, blabla , x, <IEGroup: 2>, qweljqwelkqjwelqjkq, y, + dkashdakj, z, <IEGroup: 1> ) where x = True y = False diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr index d04558c301..ad21cc37ba 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.stderr @@ -1,7 +1,13 @@ ==================== Parser ==================== module ShouldCompile where -test :: (Eq a) => [a] " doc1" -> [a] " doc2 " -> [a] " doc3" +test :: + (Eq a) => + -- | doc1 + [a] + -> [a] {-^ doc2 -} + -> -- | doc3 + [a] test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr index c453e071a3..47deb6c839 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA024.stderr @@ -1,7 +1,12 @@ ==================== Parser ==================== module ShouldCompile where -test2 :: a " doc1 " -> b " doc2 " -> a " doc 3 " +test2 :: + -- | doc1 + a + -> b {-^ doc2 -} + -> -- | doc 3 + a test2 x y = x diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr index e0b8a4a7bf..19c5a8e5a0 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA025.stderr @@ -1,7 +1,10 @@ ==================== Parser ==================== module ShouldCompile where -test2 :: a " doc1 " -> a +test2 :: + -- | doc1 + a + -> a test2 x = x diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr index 37135099a0..953adc531c 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.stderr @@ -2,7 +2,13 @@ ==================== Parser ==================== module ShouldCompile where test :: - (Eq a) => [a] " doc1" -> forall b. [b] " doc2 " -> [a] " doc3" + (Eq a) => + -- | doc1 + [a] + -> forall b. + [b] {-^ doc2 -} + -> -- | doc3 + [a] test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr index 0bbb612119..469e1a0e50 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.stderr @@ -2,9 +2,16 @@ ==================== Parser ==================== module ShouldCompile where test :: - [a] " doc1" + -- | doc1 + [a] -> forall b. - (Ord b) => [b] " doc2 " -> forall c. (Num c) => [c] " doc3" -> [a] + (Ord b) => + [b] {-^ doc2 -} + -> forall c. + (Num c) => + -- | doc3 + [c] + -> [a] test xs ys zs = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr index 3c1bbc9565..6b8ec2bcaa 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr @@ -2,7 +2,12 @@ ==================== Parser ==================== module ShouldCompile where data a <--> b = Mk a b -test :: [a] " doc1 " -> a <--> b -> [a] " blabla" +test :: + -- | doc1 + [a] + -> a <--> b + -> -- | blabla + [a] test xs ys = xs diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr index 7271238e3e..8c6ebc2c3b 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA029.stderr @@ -2,6 +2,10 @@ ==================== Parser ==================== module ShouldCompile where data A - = " A comment that documents the first constructor" A | B | C | D + = -- | A comment that documents the first constructor + A | + B | + C | + D diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr index 81b172ed80..cd8c2eaa9f 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA030.stderr @@ -2,9 +2,12 @@ ==================== Parser ==================== module ShouldCompile where data A - = " A comment that documents the first constructor" A | - " comment for B " B | - " comment for C " C | + = -- | A comment that documents the first constructor + A | + -- | comment for B + B | + -- | comment for C + C | D diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr index eb6fcaef1e..b11c4d6ea2 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA031.stderr @@ -3,7 +3,8 @@ module ShouldCompile where data A = A | - " comment for B " forall a. B a a | - " comment for C " forall a. Num a => C a + {-| comment for B -} + forall a. B a a | + forall a. Num a => C a {-^ comment for C -} diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr index eec30285f5..64a8164d02 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA032.stderr @@ -3,8 +3,11 @@ module ShouldCompile where data R a = R {field1 :: a, - field2 :: a " comment for field2", - field3 :: a " comment for field3", - field4 :: a " comment for field4 "} + -- | comment for field2 + field2 :: a, + -- | comment for field3 + field3 :: a, + {-| comment for field4 -} + field4 :: a} diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr index 64478fed12..babd1eac1c 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA034.stderr @@ -2,6 +2,9 @@ ==================== Parser ==================== module Hi where <document comment> -data Hi where " This is a GADT constructor." Hi :: () -> Hi +data Hi + where + -- | This is a GADT constructor. + Hi :: () -> Hi diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr index 3f12a0cffd..69c35fdee7 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA035.stderr @@ -3,9 +3,12 @@ module Hi where data Hi where - Hi :: () " This is a comment on the '()' field of 'Hi'" - -> Int - -> String " This is a comment on the 'String' field of 'Hi'" - -> Hi " This is a comment on the return type of 'Hi'" + Hi :: -- | This is a comment on the '()' field of 'Hi' + () -> + Int -> + -- | This is a comment on the 'String' field of 'Hi' + String -> + -- | This is a comment on the return type of 'Hi' + Hi diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr index 5cd0a59a05..8488d159fe 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA036.stderr @@ -2,13 +2,21 @@ ==================== Parser ==================== module ConstructorFields where data Foo - = " doc on `Bar` constructor" Bar Int String | - " doc on the `Baz` constructor" - Baz Int " doc on the `Int` field of `Baz`" String " doc on the `String` field of `Baz`" | - " doc on the `:+` constructor" Int :+ String | - " doc on the `:*` constructor" - Int " doc on the `Int` field of the `:*` constructor" :* String " doc on the `String` field of the `:*` constructor" | - " doc on the `Boo` record constructor" Boo {x :: ()} | - " doc on the `Boa` record constructor" Boa {y :: ()} + = -- | doc on `Bar` constructor + Bar Int String | + -- | doc on the `Baz` constructor + Baz -- | doc on the `Int` field of `Baz` + Int -- | doc on the `String` field of `Baz` + String | + -- | doc on the `:+` constructor + Int :+ String | + -- | doc on the `:*` constructor + -- | doc on the `Int` field of the `:*` constructor + Int :* -- | doc on the `String` field of the `:*` constructor + String | + -- | doc on the `Boo` record constructor + Boo {x :: ()} | + -- | doc on the `Boa` record constructor + Boa {y :: ()} diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr index b9ecfa6303..08664a1c4b 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA037.stderr @@ -4,6 +4,9 @@ module UnamedConstructorFields where data A = A data B = B data C = C -data Foo = MkFoo A " 'A' has a comment" B C " 'C' has a comment" +data Foo + = MkFoo -- | 'A' has a comment + A B -- | 'C' has a comment + C diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.stderr index 3021fa7195..b02e9f53f3 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA038.stderr @@ -3,5 +3,11 @@ module UnamedConstructorStrictFields where data A = A data B = B -data Foo = MkFoo {-# UNPACK #-} !A " Unpacked strict field" B -data Bar = {-# UNPACK #-} !A " Unpacked strict field" :%% B +data Foo + = MkFoo -- | Unpacked strict field + {-# UNPACK #-} !A B +data Bar + = -- | Unpacked strict field + {-# UNPACK #-} !A :%% B + + diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA039.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA039.stderr index 02bc5985b5..c0dc503981 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA039.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA039.stderr @@ -4,12 +4,16 @@ module CommentsBeforeArguments where data A = A data B = B f1 :: - () " Comment before " - -> () " Comment after " -> () " Result after " + {-| Comment before -} + () + -> () {-^ Comment after -} -> () {-^ Result after -} f1 _ _ = () f2 :: - () " Comment before " - -> () " Comment after " -> () " Result after " + {-| Comment before -} + () + -> () {-^ Comment after -} + -> {-| Result after -} + () f2 _ _ = () diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA040.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA040.stderr index 7cbe964357..8df64a1fe5 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA040.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA040.stderr @@ -6,8 +6,11 @@ data family U a <document comment> data instance U () = UUnit - deriving (Eq " Comment on the derived Eq (U ()) instance", - Ord " Comment on the derived Ord (U ()) instance", - Show " Comment on the derived Show (U ()) instance") + deriving (-- | Comment on the derived Eq (U ()) instance + Eq, + -- | Comment on the derived Ord (U ()) instance + Ord, + -- | Comment on the derived Show (U ()) instance + Show) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA041.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA041.stderr index 98e217c8ee..59fc62accf 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA041.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA041.stderr @@ -1,8 +1,10 @@ ==================== Parser ==================== -" Module header documentation" +-- | Module header documentation module Comments_and_CPP_include where <document comment> -data T = " Comment on MkT" MkT +data T + = -- | Comment on MkT + MkT diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.stderr index cc675fe568..ed7a77ffc9 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockTySyn.stderr @@ -1,6 +1,8 @@ ==================== Parser ==================== module HaddockTySyn where -type T = Int " Comment on type synonym RHS" +type T = + -- | Comment on type synonym RHS + Int diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index 3a6fdceac3..563eb3604f 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -186,3 +186,4 @@ test('T20609b', normal, compile, ['']) test('T20609c', normal, compile, ['']) test('T20609d', normal, compile, ['']) test('T18862', normal, compile, ['']) +test('unused_haddock', normal, compile, ['-haddock -Wall']) diff --git a/testsuite/tests/rename/should_compile/unused_haddock.hs b/testsuite/tests/rename/should_compile/unused_haddock.hs new file mode 100644 index 0000000000..ecf14de910 --- /dev/null +++ b/testsuite/tests/rename/should_compile/unused_haddock.hs @@ -0,0 +1,8 @@ +module UnusedHaddock (qux) where + +foo :: String +foo = "abc" + +-- | A version of 'foo' +qux :: () +qux = () diff --git a/testsuite/tests/rename/should_compile/unused_haddock.stderr b/testsuite/tests/rename/should_compile/unused_haddock.stderr new file mode 100644 index 0000000000..b705fed36b --- /dev/null +++ b/testsuite/tests/rename/should_compile/unused_haddock.stderr @@ -0,0 +1,3 @@ + +unused_haddock.hs:4:1: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)] + Defined but not used: ‘foo’ diff --git a/testsuite/tests/showIface/DocsInHiFile0.stdout b/testsuite/tests/showIface/DocsInHiFile0.stdout index 352dae916f..1f20d7961a 100644 --- a/testsuite/tests/showIface/DocsInHiFile0.stdout +++ b/testsuite/tests/showIface/DocsInHiFile0.stdout @@ -1,5 +1,4 @@ -module header: +docs: Nothing -declaration docs: -arg docs: extensible fields: + diff --git a/testsuite/tests/showIface/DocsInHiFile1.stdout b/testsuite/tests/showIface/DocsInHiFile1.stdout index fa642627d6..093d07614c 100644 --- a/testsuite/tests/showIface/DocsInHiFile1.stdout +++ b/testsuite/tests/showIface/DocsInHiFile1.stdout @@ -1,40 +1,147 @@ -module header: - Just " `elem`, 'print', +docs: + Just module header: + Just text: + {-| `elem`, 'print', `Unknown', '<>', ':=:', 'Bool' -" -declaration docs: - elem: - " '()', 'elem'." - D: - " A datatype." - D0: - " A constructor for 'D'. '" - D1: - " Another constructor" - P: - " A class" - p: - " A class method" - $fShowD: - " 'Show' instance" - D': - " Another datatype... - - ...with two docstrings." - D:R:FInt: - " A type family instance" - F: - " A type family" -arg docs: - add: - 0: - " First summand for 'add'" - 1: - " Second summand" - 2: - " Sum" - p: - 0: - " An argument" +-} + identifiers: + {DocsInHiFile.hs:2:3-6} + Data.Foldable.elem + {DocsInHiFile.hs:2:3-6} + elem + {DocsInHiFile.hs:2:11-15} + System.IO.print + {DocsInHiFile.hs:4:2-3} + GHC.Base.<> + {DocsInHiFile.hs:4:15-18} + GHC.Types.Bool + declaration docs: + [elem -> [text: + -- | '()', 'elem'. + identifiers: + {DocsInHiFile.hs:14:13-16} + Data.Foldable.elem + {DocsInHiFile.hs:14:13-16} + elem], + D -> [text: + -- | A datatype. + identifiers:], + D0 -> [text: + -- ^ A constructor for 'D'. ' + identifiers: + {DocsInHiFile.hs:20:32} + D], + D1 -> [text: + -- ^ Another constructor + identifiers:], + P -> [text: + -- | A class + identifiers:], + p -> [text: + -- | A class method + identifiers:], + $fShowD -> [text: + -- ^ 'Show' instance + identifiers: + {DocsInHiFile.hs:22:25-28} + GHC.Show.Show], + D' -> [text: + -- | Another datatype... + identifiers:, + text: + -- ^ ...with two docstrings. + identifiers:], + D:R:FInt -> [text: + -- | A type family instance + identifiers:], + F -> [text: + -- | A type family + identifiers:]] + arg docs: + [add -> 0: + text: + -- ^ First summand for 'add' + identifiers: + {DocsInHiFile.hs:25:36-38} + add + 1: + text: + -- ^ Second summand + identifiers: + 2: + text: + -- ^ Sum + identifiers:, + p -> 0: + text: + -- ^ An argument + identifiers:] + documentation structure: + avails: + [elem] + avails: + [D{D, D0, D1}] + avails: + [add] + avails: + [P{P, p}] + avails: + [GHC.Show.Show{GHC.Show.Show, GHC.Show.show, GHC.Show.showList, + GHC.Show.showsPrec}] + named chunks: + haddock options: + language: + Nothing + language extensions: + MonomorphismRestriction + MonoLocalBinds + RelaxedPolyRec + ForeignFunctionInterface + ImplicitPrelude + ScopedTypeVariables + BangPatterns + TypeFamilies + NamedFieldPuns + GADTSyntax + DoAndIfThenElse + ConstraintKinds + PolyKinds + InstanceSigs + StandaloneDeriving + DeriveDataTypeable + DeriveFunctor + DeriveTraversable + DeriveFoldable + DeriveGeneric + DeriveLift + TypeSynonymInstances + FlexibleContexts + FlexibleInstances + ConstrainedClassMethods + MultiParamTypeClasses + ExistentialQuantification + EmptyDataDecls + KindSignatures + GeneralizedNewtypeDeriving + PostfixOperators + TupleSections + PatternGuards + RankNTypes + TypeOperators + ExplicitNamespaces + ExplicitForAll + TraditionalRecordSyntax + BinaryLiterals + HexFloatLiterals + EmptyCase + NamedWildCards + TypeApplications + EmptyDataDeriving + NumericUnderscores + StarIsType + ImportQualifiedPost + StandaloneKindSignatures + FieldSelectors extensible fields: + diff --git a/testsuite/tests/showIface/DocsInHiFileTH.hs b/testsuite/tests/showIface/DocsInHiFileTH.hs index 73b46c8876..4186c6a876 100644 --- a/testsuite/tests/showIface/DocsInHiFileTH.hs +++ b/testsuite/tests/showIface/DocsInHiFileTH.hs @@ -24,8 +24,8 @@ do Just "A constructor" <- getDoc (DeclDoc 'Foo) putDoc (DeclDoc ''Foo) "A new data type" putDoc (DeclDoc 'Foo) "A new constructor" - Just "A new data type" <- getDoc (DeclDoc ''Foo) Just "A new constructor" <- getDoc (DeclDoc 'Foo) + Just "A new data type" <- getDoc (DeclDoc ''Foo) pure [] -- |Some documentation diff --git a/testsuite/tests/showIface/DocsInHiFileTH.stdout b/testsuite/tests/showIface/DocsInHiFileTH.stdout index 6951b9a1e5..0e9c1af6d5 100644 --- a/testsuite/tests/showIface/DocsInHiFileTH.stdout +++ b/testsuite/tests/showIface/DocsInHiFileTH.stdout @@ -1,118 +1,290 @@ -module header: - Just "This is the new module header" -declaration docs: - Tup2: - "Matches a tuple of (a, a)" - f: - "The meaning of life" - g: - "Some documentation" - qux: - "This is qux" - sin: - "15" - wd1: - "1" - wd17: - "17" - wd18: - "18" - wd2: - "2" - wd20: - "20" - wd8: - "8" - C: - "A new class" - Corge: - "This is a newtype record constructor" - runCorge: - "This is the newtype record constructor's argument" - E: - "A type family" - Foo: - "A new data type" - Foo: - "A new constructor" - Pretty: - "My cool class" - prettyPrint: - "Prettily prints the object" - Quux: - "This is Quux" - Quux1: - "This is Quux1" - Quux2: - "This is Quux2" - Quuz: - "This is a record constructor" - quuz1_a: - "This is the record constructor's argument" - WD10: - "10" - WD11Bool: - "This is a newtype instance constructor" - WD11Int: - "This is a data instance constructor" - WD12: - "12" - WD3: - "3" - WD4: - "4" - WD5: - "5" - WD6: - "6" - $fCTYPEFoo: - "7" - $fCTYPEInt: - "A new instance" - $fCTYPE[]: - "Another new instance" - $fDka: - "Another new instance" - $fF: - "14" - D:R:EBool: - "A type family instance" - D:R:WD11Bool0: - "This is a newtype instance" - D:R:WD11Foo0: - "11" - D:R:WD11Int0: - "This is a data instance" - D:R:WD13Foo: - "13" -arg docs: - Tup2: - 0: - "The thing to match twice" - h: - 0: - "Your favourite number" - 1: - "Your least favourite Boolean" - 2: - "A return value" - qux: - 0: - "Arg uno" - 1: - "Arg dos" - Quux1: - 0: - "I am an integer" - Quux2: - 0: - "I am a string" - 1: - "I am a bool" - WD11Bool: - 0: - "This is a newtype instance constructor argument" - WD11Int: - 0: - "This is a data instance constructor argument" +docs: + Just module header: + Just text: + -- |This is the new module header + identifiers: + declaration docs: + [Tup2 -> [text: + -- |Matches a tuple of (a, a) + identifiers:], + f -> [text: + -- |The meaning of life + identifiers:], + g -> [text: + -- |Some documentation + identifiers:], + qux -> [text: + -- |This is qux + identifiers:], + sin -> [text: + -- |15 + identifiers:], + wd1 -> [text: + -- |1 + identifiers:], + wd17 -> [text: + -- |17 + identifiers:], + wd18 -> [text: + -- |18 + identifiers:], + wd2 -> [text: + -- |2 + identifiers:], + wd20 -> [text: + -- |20 + identifiers:], + wd8 -> [text: + -- |8 + identifiers:], + C -> [text: + -- |A new class + identifiers:], + Corge -> [text: + -- |This is a newtype record constructor + identifiers:], + runCorge -> [text: + -- |This is the newtype record constructor's argument + identifiers:], + E -> [text: + -- |A type family + identifiers:], + Foo -> [text: + -- |A new data type + identifiers:], + Foo -> [text: + -- |A new constructor + identifiers:], + Pretty -> [text: + -- |My cool class + identifiers:], + prettyPrint -> [text: + -- |Prettily prints the object + identifiers:], + Quux -> [text: + -- |This is Quux + identifiers:], + Quux1 -> [text: + -- |This is Quux1 + identifiers:], + Quux2 -> [text: + -- |This is Quux2 + identifiers:], + Quuz -> [text: + -- |This is a record constructor + identifiers:], + quuz1_a -> [text: + -- |This is the record constructor's argument + identifiers:], + WD10 -> [text: + -- |10 + identifiers:], + WD11Bool -> [text: + -- |This is a newtype instance constructor + identifiers:], + WD11Int -> [text: + -- |This is a data instance constructor + identifiers:], + WD12 -> [text: + -- |12 + identifiers:], + WD3 -> [text: + -- |3 + identifiers:], + WD4 -> [text: + -- |4 + identifiers:], + WD5 -> [text: + -- |5 + identifiers:], + WD6 -> [text: + -- |6 + identifiers:], + $fCTYPEFoo -> [text: + -- |7 + identifiers:], + $fCTYPEInt -> [text: + -- |A new instance + identifiers:], + $fCTYPE[] -> [text: + -- |Another new instance + identifiers:], + $fDka -> [text: + -- |Another new instance + identifiers:], + $fF -> [text: + -- |14 + identifiers:], + D:R:EBool -> [text: + -- |A type family instance + identifiers:], + D:R:WD11Bool0 -> [text: + -- |This is a newtype instance + identifiers:], + D:R:WD11Foo0 -> [text: + -- |11 + identifiers:], + D:R:WD11Int0 -> [text: + -- |This is a data instance + identifiers:], + D:R:WD13Foo -> [text: + -- |13 + identifiers:]] + arg docs: + [Tup2 -> 0: + text: + -- |The thing to match twice + identifiers:, + h -> 0: + text: + -- ^Your favourite number + identifiers: + 1: + text: + -- |Your least favourite Boolean + identifiers: + 2: + text: + -- ^A return value + identifiers:, + qux -> 1: + text: + -- |Arg dos + identifiers:, + Quux1 -> 0: + text: + -- |I am an integer + identifiers:, + Quux2 -> 1: + text: + -- |I am a bool + identifiers:, + WD11Bool -> 0: + text: + -- |This is a newtype instance constructor argument + identifiers:, + WD11Int -> 0: + text: + -- |This is a data instance constructor argument + identifiers:] + documentation structure: + avails: + [f] + avails: + [Foo{Foo, Foo}] + avails: + [g] + avails: + [h] + avails: + [C{C}] + avails: + [D{D}] + avails: + [E{E}] + avails: + [i] + avails: + [WD11{WD11, WD11Bool, WD11Int, WD11Foo}] + avails: + [WD13{WD13}] + avails: + [wd8] + avails: + [F{F}] + avails: + [wd1] + avails: + [wd2] + avails: + [WD3{WD3, WD3}] + avails: + [WD4{WD4, WD4}] + avails: + [WD5{WD5}] + avails: + [WD6{WD6}] + avails: + [WD10{WD10}] + avails: + [WD12{WD12}] + avails: + [sin] + avails: + [wd17] + avails: + [wd18] + avails: + [wd20] + avails: + [Pretty{Pretty, prettyPrint}] + avails: + [Corge{Corge, runCorge, Corge}] + avails: + [Quuz{Quuz, quuz1_a, Quuz}] + avails: + [Quux{Quux, Quux2, Quux1}] + avails: + [Tup2] + avails: + [qux] + named chunks: + haddock options: + language: + Nothing + language extensions: + MonomorphismRestriction + MonoLocalBinds + RelaxedPolyRec + ForeignFunctionInterface + TemplateHaskell + TemplateHaskellQuotes + ImplicitPrelude + ScopedTypeVariables + BangPatterns + TypeFamilies + NamedFieldPuns + GADTSyntax + DoAndIfThenElse + ConstraintKinds + PolyKinds + DataKinds + InstanceSigs + StandaloneDeriving + DeriveDataTypeable + DeriveFunctor + DeriveTraversable + DeriveFoldable + DeriveGeneric + DeriveLift + TypeSynonymInstances + FlexibleContexts + FlexibleInstances + ConstrainedClassMethods + MultiParamTypeClasses + ExistentialQuantification + EmptyDataDecls + KindSignatures + GeneralizedNewtypeDeriving + PostfixOperators + TupleSections + PatternGuards + RankNTypes + TypeOperators + ExplicitNamespaces + ExplicitForAll + TraditionalRecordSyntax + BinaryLiterals + HexFloatLiterals + EmptyCase + PatternSynonyms + NamedWildCards + TypeApplications + EmptyDataDeriving + NumericUnderscores + StarIsType + ImportQualifiedPost + StandaloneKindSignatures + FieldSelectors extensible fields: + diff --git a/testsuite/tests/showIface/HaddockIssue849.hs b/testsuite/tests/showIface/HaddockIssue849.hs new file mode 100644 index 0000000000..d8b34a2d8a --- /dev/null +++ b/testsuite/tests/showIface/HaddockIssue849.hs @@ -0,0 +1,10 @@ +module HaddockIssue849 + ( module Data.Functor.Identity + , module Data.Maybe + , module Data.Tuple + ) where + +import qualified Data.Functor.Identity +import qualified Data.Maybe +import Data.Tuple (swap) +import qualified Data.Tuple diff --git a/testsuite/tests/showIface/HaddockIssue849.stdout b/testsuite/tests/showIface/HaddockIssue849.stdout new file mode 100644 index 0000000000..197f83df62 --- /dev/null +++ b/testsuite/tests/showIface/HaddockIssue849.stdout @@ -0,0 +1,70 @@ +docs: + Just module header: + Nothing + declaration docs: + [] + arg docs: + [] + documentation structure: + re-exported module(s): [Data.Functor.Identity] + [] + re-exported module(s): [Data.Maybe] + [GHC.Maybe.Maybe{GHC.Maybe.Maybe, GHC.Maybe.Nothing, + GHC.Maybe.Just}, + Data.Maybe.maybe] + re-exported module(s): [Data.Tuple] + [Data.Tuple.swap, Data.Tuple.curry, Data.Tuple.fst, Data.Tuple.snd, + Data.Tuple.uncurry] + named chunks: + haddock options: + language: + Nothing + language extensions: + MonomorphismRestriction + RelaxedPolyRec + ForeignFunctionInterface + ImplicitPrelude + ScopedTypeVariables + BangPatterns + NamedFieldPuns + GADTSyntax + DoAndIfThenElse + ConstraintKinds + PolyKinds + InstanceSigs + StandaloneDeriving + DeriveDataTypeable + DeriveFunctor + DeriveTraversable + DeriveFoldable + DeriveGeneric + DeriveLift + TypeSynonymInstances + FlexibleContexts + FlexibleInstances + ConstrainedClassMethods + MultiParamTypeClasses + ExistentialQuantification + EmptyDataDecls + KindSignatures + GeneralizedNewtypeDeriving + PostfixOperators + TupleSections + PatternGuards + RankNTypes + TypeOperators + ExplicitForAll + TraditionalRecordSyntax + BinaryLiterals + HexFloatLiterals + EmptyCase + NamedWildCards + TypeApplications + EmptyDataDeriving + NumericUnderscores + StarIsType + ImportQualifiedPost + StandaloneKindSignatures + FieldSelectors +extensible fields: + diff --git a/testsuite/tests/showIface/HaddockOpts.hs b/testsuite/tests/showIface/HaddockOpts.hs new file mode 100644 index 0000000000..6e90e051db --- /dev/null +++ b/testsuite/tests/showIface/HaddockOpts.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_HADDOCK not-home, show-extensions #-} +module HaddockOpts where diff --git a/testsuite/tests/showIface/HaddockOpts.stdout b/testsuite/tests/showIface/HaddockOpts.stdout new file mode 100644 index 0000000000..60a0535457 --- /dev/null +++ b/testsuite/tests/showIface/HaddockOpts.stdout @@ -0,0 +1,62 @@ +docs: + Just module header: + Nothing + declaration docs: + [] + arg docs: + [] + documentation structure: + named chunks: + haddock options: + not-home, show-extensions + language: + Nothing + language extensions: + MonomorphismRestriction + RelaxedPolyRec + ForeignFunctionInterface + ImplicitPrelude + ScopedTypeVariables + BangPatterns + NamedFieldPuns + GADTSyntax + DoAndIfThenElse + ConstraintKinds + PolyKinds + InstanceSigs + StandaloneDeriving + DeriveDataTypeable + DeriveFunctor + DeriveTraversable + DeriveFoldable + DeriveGeneric + DeriveLift + TypeSynonymInstances + FlexibleContexts + FlexibleInstances + ConstrainedClassMethods + MultiParamTypeClasses + ExistentialQuantification + EmptyDataDecls + KindSignatures + GeneralizedNewtypeDeriving + PostfixOperators + TupleSections + PatternGuards + RankNTypes + TypeOperators + ExplicitForAll + TraditionalRecordSyntax + BinaryLiterals + HexFloatLiterals + EmptyCase + NamedWildCards + TypeApplications + EmptyDataDeriving + NumericUnderscores + StarIsType + ImportQualifiedPost + StandaloneKindSignatures + FieldSelectors +extensible fields: + diff --git a/testsuite/tests/showIface/Inner0.hs b/testsuite/tests/showIface/Inner0.hs new file mode 100644 index 0000000000..2e89d86d09 --- /dev/null +++ b/testsuite/tests/showIface/Inner0.hs @@ -0,0 +1,3 @@ +module Inner0 where + +inner0_0 = () diff --git a/testsuite/tests/showIface/Inner1.hs b/testsuite/tests/showIface/Inner1.hs new file mode 100644 index 0000000000..e745a1504c --- /dev/null +++ b/testsuite/tests/showIface/Inner1.hs @@ -0,0 +1,4 @@ +module Inner1 where + +inner1_0 = () +inner1_1 = () diff --git a/testsuite/tests/showIface/Inner2.hs b/testsuite/tests/showIface/Inner2.hs new file mode 100644 index 0000000000..aff4cb4127 --- /dev/null +++ b/testsuite/tests/showIface/Inner2.hs @@ -0,0 +1,3 @@ +module Inner2 where + +inner2_0 = () diff --git a/testsuite/tests/showIface/Inner3.hs b/testsuite/tests/showIface/Inner3.hs new file mode 100644 index 0000000000..79b33ffde0 --- /dev/null +++ b/testsuite/tests/showIface/Inner3.hs @@ -0,0 +1,3 @@ +module Inner3 where + +inner3_0 = () diff --git a/testsuite/tests/showIface/Inner4.hs b/testsuite/tests/showIface/Inner4.hs new file mode 100644 index 0000000000..6e56448590 --- /dev/null +++ b/testsuite/tests/showIface/Inner4.hs @@ -0,0 +1,4 @@ +module Inner4 where + +inner4_0 = () +inner4_1 = () diff --git a/testsuite/tests/showIface/LanguageExts.hs b/testsuite/tests/showIface/LanguageExts.hs new file mode 100644 index 0000000000..3a8b71fe72 --- /dev/null +++ b/testsuite/tests/showIface/LanguageExts.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE Haskell98 #-} +{-# LANGUAGE NPlusKPatterns #-} +{-# LANGUAGE PatternGuards #-} +module LanguageExts where diff --git a/testsuite/tests/showIface/LanguageExts.stdout b/testsuite/tests/showIface/LanguageExts.stdout new file mode 100644 index 0000000000..c155327230 --- /dev/null +++ b/testsuite/tests/showIface/LanguageExts.stdout @@ -0,0 +1,25 @@ +docs: + Just module header: + Nothing + declaration docs: + [] + arg docs: + [] + documentation structure: + named chunks: + haddock options: + language: + Just Haskell98 + language extensions: + MonomorphismRestriction + ImplicitPrelude + NPlusKPatterns + PatternGuards + DatatypeContexts + NondecreasingIndentation + TraditionalRecordSyntax + StarIsType + CUSKs + FieldSelectors +extensible fields: + diff --git a/testsuite/tests/showIface/MagicHashInHaddocks.hs b/testsuite/tests/showIface/MagicHashInHaddocks.hs new file mode 100644 index 0000000000..ef7e1df48c --- /dev/null +++ b/testsuite/tests/showIface/MagicHashInHaddocks.hs @@ -0,0 +1,9 @@ +{-# language MagicHash #-} + +-- | 'foo#' `Bar##` `*##` +module MagicHashInHaddocks where + +foo# :: () +foo# = () + +data Bar## diff --git a/testsuite/tests/showIface/MagicHashInHaddocks.stdout b/testsuite/tests/showIface/MagicHashInHaddocks.stdout new file mode 100644 index 0000000000..3b3d44f08d --- /dev/null +++ b/testsuite/tests/showIface/MagicHashInHaddocks.stdout @@ -0,0 +1,72 @@ +docs: + Just module header: + Just text: + -- | 'foo#' `Bar##` `*##` + identifiers: + {MagicHashInHaddocks.hs:3:7-10} + foo# + {MagicHashInHaddocks.hs:3:14-18} + Bar## + declaration docs: + [] + arg docs: + [] + documentation structure: + avails: + [foo#] + avails: + [Bar##{Bar##}] + named chunks: + haddock options: + language: + Nothing + language extensions: + MonomorphismRestriction + RelaxedPolyRec + ForeignFunctionInterface + ImplicitPrelude + ScopedTypeVariables + BangPatterns + NamedFieldPuns + GADTSyntax + DoAndIfThenElse + ConstraintKinds + PolyKinds + InstanceSigs + StandaloneDeriving + DeriveDataTypeable + DeriveFunctor + DeriveTraversable + DeriveFoldable + DeriveGeneric + DeriveLift + TypeSynonymInstances + FlexibleContexts + FlexibleInstances + ConstrainedClassMethods + MultiParamTypeClasses + ExistentialQuantification + MagicHash + EmptyDataDecls + KindSignatures + GeneralizedNewtypeDeriving + PostfixOperators + TupleSections + PatternGuards + RankNTypes + TypeOperators + ExplicitForAll + TraditionalRecordSyntax + BinaryLiterals + HexFloatLiterals + EmptyCase + NamedWildCards + TypeApplications + EmptyDataDeriving + NumericUnderscores + StarIsType + ImportQualifiedPost + StandaloneKindSignatures + FieldSelectors +extensible fields: + diff --git a/testsuite/tests/showIface/Makefile b/testsuite/tests/showIface/Makefile index c45f38684e..834f6cb2dd 100644 --- a/testsuite/tests/showIface/Makefile +++ b/testsuite/tests/showIface/Makefile @@ -8,12 +8,40 @@ Orphans: DocsInHiFile0: '$(TEST_HC)' $(TEST_HC_OPTS) -c DocsInHiFile.hs - '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 4 'module header:' + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 4 'docs:' DocsInHiFile1: '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock DocsInHiFile.hs - '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 100 'module header:' + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFile.hi | grep -A 100 'docs:' DocsInHiFileTH: '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock DocsInHiFileTHExternal.hs DocsInHiFileTH.hs - '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFileTH.hi | grep -A 200 'module header:' + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface DocsInHiFileTH.hi | grep -A 200 'docs:' + +NoExportList: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock NoExportList.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface NoExportList.hi | grep -A 100 'docs:' + +PragmaDocs: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock PragmaDocs.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface PragmaDocs.hi | grep -A 100 'Warnings:' + +HaddockOpts: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock HaddockOpts.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface HaddockOpts.hi | grep -A 100 'docs:' + +LanguageExts: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock LanguageExts.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface LanguageExts.hi | grep -A 100 'docs:' + +ReExports: + '$(TEST_HC)' $(TEST_HC_OPTS) --make -haddock -v0 Inner0 Inner1 Inner2 Inner3 Inner4 ReExports + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface ReExports.hi | grep -A 200 'docs:' + +HaddockIssue849: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock HaddockIssue849.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface HaddockIssue849.hi | grep -A 200 'docs:' + +MagicHashInHaddocks: + '$(TEST_HC)' $(TEST_HC_OPTS) -c -haddock MagicHashInHaddocks.hs + '$(TEST_HC)' $(TEST_HC_OPTS) --show-iface MagicHashInHaddocks.hi | grep -A 200 'docs:' diff --git a/testsuite/tests/showIface/NoExportList.hs b/testsuite/tests/showIface/NoExportList.hs new file mode 100644 index 0000000000..3808e95162 --- /dev/null +++ b/testsuite/tests/showIface/NoExportList.hs @@ -0,0 +1,28 @@ +-- | Module header +module NoExportList where + +import qualified Data.List + +-- * Types +-- +-- $types +-- +-- Actually we have only one type. + +data R = R + { fα :: () -- ^ Documentation for 'R'\'s 'fα' field. + , fβ :: () + } + +-- | A very lazy Eq instance +instance Eq R where + _r0 == _r1 = True + +-- * Functions +-- +-- $functions +-- +-- We have them too. + +add :: Int -> Int -> Int +add = (+) diff --git a/testsuite/tests/showIface/NoExportList.stdout b/testsuite/tests/showIface/NoExportList.stdout new file mode 100644 index 0000000000..3fec2d6c88 --- /dev/null +++ b/testsuite/tests/showIface/NoExportList.stdout @@ -0,0 +1,98 @@ +docs: + Just module header: + Just text: + -- | Module header + identifiers: + declaration docs: + [fα -> [text: + -- ^ Documentation for 'R'\'s 'fα' field. + identifiers: + {NoExportList.hs:13:38} + R + {NoExportList.hs:13:38} + R + {NoExportList.hs:13:45-46} + fα], + $fEqR -> [text: + -- | A very lazy Eq instance + identifiers:]] + arg docs: + [] + documentation structure: + section heading, level 1: + text: + -- * Types + identifiers: + documentation chunk: + text: + -- $types +-- +-- Actually we have only one type. + identifiers: + avails: + [R{R, fβ, fα, R}] + section heading, level 1: + text: + -- * Functions + identifiers: + documentation chunk: + text: + -- $functions +-- +-- We have them too. + identifiers: + avails: + [add] + named chunks: + haddock options: + language: + Nothing + language extensions: + MonomorphismRestriction + RelaxedPolyRec + ForeignFunctionInterface + ImplicitPrelude + ScopedTypeVariables + BangPatterns + NamedFieldPuns + GADTSyntax + DoAndIfThenElse + ConstraintKinds + PolyKinds + InstanceSigs + StandaloneDeriving + DeriveDataTypeable + DeriveFunctor + DeriveTraversable + DeriveFoldable + DeriveGeneric + DeriveLift + TypeSynonymInstances + FlexibleContexts + FlexibleInstances + ConstrainedClassMethods + MultiParamTypeClasses + ExistentialQuantification + EmptyDataDecls + KindSignatures + GeneralizedNewtypeDeriving + PostfixOperators + TupleSections + PatternGuards + RankNTypes + TypeOperators + ExplicitForAll + TraditionalRecordSyntax + BinaryLiterals + HexFloatLiterals + EmptyCase + NamedWildCards + TypeApplications + EmptyDataDeriving + NumericUnderscores + StarIsType + ImportQualifiedPost + StandaloneKindSignatures + FieldSelectors +extensible fields: + diff --git a/testsuite/tests/showIface/PragmaDocs.hs b/testsuite/tests/showIface/PragmaDocs.hs new file mode 100644 index 0000000000..3e7a068d71 --- /dev/null +++ b/testsuite/tests/showIface/PragmaDocs.hs @@ -0,0 +1,9 @@ +module PragmaDocs where + +{-# DEPRECATED contains "Use `elem` instead." #-} +contains :: (Eq a, Foldable f) => f a -> a -> Bool +contains = flip elem + +{-# warning x, y "These are useless" #-} +x = () +y = () diff --git a/testsuite/tests/showIface/PragmaDocs.stdout b/testsuite/tests/showIface/PragmaDocs.stdout new file mode 100644 index 0000000000..bd8ba16957 --- /dev/null +++ b/testsuite/tests/showIface/PragmaDocs.stdout @@ -0,0 +1,72 @@ +Warnings: x "These are useless" + y "These are useless" + contains "Use `elem` instead." +trusted: none +require own pkg trusted: False +docs: + Just module header: + Nothing + declaration docs: + [] + arg docs: + [] + documentation structure: + avails: + [contains] + avails: + [x] + avails: + [y] + named chunks: + haddock options: + language: + Nothing + language extensions: + MonomorphismRestriction + RelaxedPolyRec + ForeignFunctionInterface + ImplicitPrelude + ScopedTypeVariables + BangPatterns + NamedFieldPuns + GADTSyntax + DoAndIfThenElse + ConstraintKinds + PolyKinds + InstanceSigs + StandaloneDeriving + DeriveDataTypeable + DeriveFunctor + DeriveTraversable + DeriveFoldable + DeriveGeneric + DeriveLift + TypeSynonymInstances + FlexibleContexts + FlexibleInstances + ConstrainedClassMethods + MultiParamTypeClasses + ExistentialQuantification + EmptyDataDecls + KindSignatures + GeneralizedNewtypeDeriving + PostfixOperators + TupleSections + PatternGuards + RankNTypes + TypeOperators + ExplicitForAll + TraditionalRecordSyntax + BinaryLiterals + HexFloatLiterals + EmptyCase + NamedWildCards + TypeApplications + EmptyDataDeriving + NumericUnderscores + StarIsType + ImportQualifiedPost + StandaloneKindSignatures + FieldSelectors +extensible fields: + diff --git a/testsuite/tests/showIface/ReExports.hs b/testsuite/tests/showIface/ReExports.hs new file mode 100644 index 0000000000..36072cece6 --- /dev/null +++ b/testsuite/tests/showIface/ReExports.hs @@ -0,0 +1,12 @@ +module ReExports + ( module Inner0 + , module Inner1 + , inner2_0 + , module X + ) where + +import Inner0 +import Inner1 hiding (inner1_0) +import Inner2 +import Inner3 as X +import Inner4 as X hiding (inner4_0) diff --git a/testsuite/tests/showIface/ReExports.stdout b/testsuite/tests/showIface/ReExports.stdout new file mode 100644 index 0000000000..31007df259 --- /dev/null +++ b/testsuite/tests/showIface/ReExports.stdout @@ -0,0 +1,69 @@ +docs: + Just module header: + Nothing + declaration docs: + [] + arg docs: + [] + documentation structure: + re-exported module(s): [Inner0] + [Inner0.inner0_0] + re-exported module(s): [Inner1] + [Inner1.inner1_1] + avails: + [Inner2.inner2_0] + re-exported module(s): [Inner3, Inner4] + [Inner3.inner3_0, Inner4.inner4_1] + named chunks: + haddock options: + language: + Nothing + language extensions: + MonomorphismRestriction + RelaxedPolyRec + ForeignFunctionInterface + ImplicitPrelude + ScopedTypeVariables + BangPatterns + NamedFieldPuns + GADTSyntax + DoAndIfThenElse + ConstraintKinds + PolyKinds + InstanceSigs + StandaloneDeriving + DeriveDataTypeable + DeriveFunctor + DeriveTraversable + DeriveFoldable + DeriveGeneric + DeriveLift + TypeSynonymInstances + FlexibleContexts + FlexibleInstances + ConstrainedClassMethods + MultiParamTypeClasses + ExistentialQuantification + EmptyDataDecls + KindSignatures + GeneralizedNewtypeDeriving + PostfixOperators + TupleSections + PatternGuards + RankNTypes + TypeOperators + ExplicitForAll + TraditionalRecordSyntax + BinaryLiterals + HexFloatLiterals + EmptyCase + NamedWildCards + TypeApplications + EmptyDataDeriving + NumericUnderscores + StarIsType + ImportQualifiedPost + StandaloneKindSignatures + FieldSelectors +extensible fields: + diff --git a/testsuite/tests/showIface/all.T b/testsuite/tests/showIface/all.T index a5e5f5f085..0de1ae6e6c 100644 --- a/testsuite/tests/showIface/all.T +++ b/testsuite/tests/showIface/all.T @@ -9,3 +9,31 @@ test('T17871', [extra_files(['T17871a.hs'])], multimod_compile, ['T17871', '-v0' test('DocsInHiFileTH', extra_files(['DocsInHiFileTHExternal.hs', 'DocsInHiFileTH.hs']), makefile_test, ['DocsInHiFileTH']) +test('NoExportList', + normal, + run_command, + ['$MAKE -s --no-print-directory NoExportList']) +test('PragmaDocs', + normal, + run_command, + ['$MAKE -s --no-print-directory PragmaDocs']) +test('HaddockOpts', + normal, + run_command, + ['$MAKE -s --no-print-directory HaddockOpts']) +test('LanguageExts', + normal, + run_command, + ['$MAKE -s --no-print-directory LanguageExts']) +test('ReExports', + extra_files(['Inner0.hs', 'Inner1.hs', 'Inner2.hs', 'Inner3.hs', 'Inner4.hs']), + run_command, + ['$MAKE -s --no-print-directory ReExports']) +test('HaddockIssue849', + normal, + run_command, + ['$MAKE -s --no-print-directory HaddockIssue849']) +test('MagicHashInHaddocks', + normal, + run_command, + ['$MAKE -s --no-print-directory MagicHashInHaddocks']) diff --git a/testsuite/tests/warnings/should_compile/DeprU.stderr b/testsuite/tests/warnings/should_compile/DeprU.stderr index 158f25228f..f8db14ef0f 100644 --- a/testsuite/tests/warnings/should_compile/DeprU.stderr +++ b/testsuite/tests/warnings/should_compile/DeprU.stderr @@ -3,7 +3,7 @@ DeprU.hs:3:1: warning: [-Wdeprecations (in -Wdefault)] Module ‘DeprM’ is deprecated: - Here can be your menacing deprecation warning! + "Here can be your menacing deprecation warning!" DeprU.hs:6:5: warning: [-Wdeprecations (in -Wdefault)] In the use of ‘f’ (imported from DeprM): diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 3b6a0ba148..67aa1f280d 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -43,7 +43,7 @@ import Control.Monad.RWS import Data.Data ( Data ) import Data.Foldable import Data.Typeable -import Data.List ( partition, sort, sortBy) +import Data.List ( partition, sortBy) import Data.List.NonEmpty ( NonEmpty ) import Data.Maybe ( isJust ) @@ -52,6 +52,7 @@ import Data.Void import Lookup import Utils import Types +import Data.Ord -- import Debug.Trace @@ -586,7 +587,7 @@ markAnnKw (EpAnn _ a _) f kw = markKwA kw (f a) markAnnKwAll :: EpAnn a -> (a -> [EpaLocation]) -> AnnKeywordId -> EPP () markAnnKwAll EpAnnNotUsed _ _ = return () -markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sort (f a)) +markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sortBy (comparing unsafeGetEpaLoc) (f a)) markAnnKwM :: EpAnn a -> (a -> Maybe EpaLocation) -> AnnKeywordId -> EPP () markAnnKwM EpAnnNotUsed _ _ = return () @@ -609,12 +610,20 @@ markEpAnn' (EpAnn _ a _) f kw = mark (f a) kw markEpAnnAll :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () markEpAnnAll EpAnnNotUsed _ _ = return () -markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sort anns) +markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sortBy (comparing unsafeGetEpAnnLoc) anns) where anns = filter (\(AddEpAnn ka _) -> ka == kw) (f a) +unsafeGetEpAnnLoc :: AddEpAnn -> RealSrcSpan +unsafeGetEpAnnLoc (AddEpAnn _ ss) = unsafeGetEpaLoc ss + + +unsafeGetEpaLoc :: EpaLocation -> RealSrcSpan +unsafeGetEpaLoc (EpaSpan real) = real +unsafeGetEpaLoc (EpaDelta _ _) = error "DELTA" + markAnnAll :: [AddEpAnn] -> AnnKeywordId -> EPP () -markAnnAll a kw = mapM_ markKw (sort anns) +markAnnAll a kw = mapM_ markKw (sortBy (comparing unsafeGetEpAnnLoc) anns) where anns = filter (\(AddEpAnn ka _) -> ka == kw) a @@ -658,7 +667,7 @@ markAnnList' reallyTrail ann action = do debugM $ "markAnnList : " ++ showPprUnsafe (p, ann) mapM_ markAddEpAnn (al_open ann) unless reallyTrail $ markTrailing (al_trailing ann) -- Only makes sense for HsModule. - markAnnAll (sort $ al_rest ann) AnnSemi + markAnnAll (sortBy (comparing unsafeGetEpAnnLoc) $ al_rest ann) AnnSemi action mapM_ markAddEpAnn (al_close ann) debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann) @@ -731,7 +740,7 @@ instance ExactPrint ModuleName where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP WarningTxt) where +instance ExactPrint (LocatedP (WarningTxt GhcPs)) where getAnnotationEntry = entryFromLocatedA exact (L (SrcSpanAnn an _) (WarningTxt (L _ src) ws)) = do markAnnOpenP an src "{-# WARNING" @@ -798,7 +807,11 @@ instance ExactPrint (ImportDecl GhcPs) where instance ExactPrint HsDocString where getAnnotationEntry _ = NoEntryVal - exact = withPpr -- TODO:AZ use annotations + exact = printStringAdvance . exactPrintHsDocString + +instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where + getAnnotationEntry _ = NoEntryVal + exact = exact . hsDocString -- --------------------------------------------------------------------- @@ -1088,18 +1101,14 @@ instance ExactPrint (SpliceDecl GhcPs) where -- --------------------------------------------------------------------- -instance ExactPrint DocDecl where +instance ExactPrint (DocDecl GhcPs) where getAnnotationEntry = const NoEntryVal - exact v = - let str = - case v of - (DocCommentNext ds) -> unpackHDS ds - (DocCommentPrev ds) -> unpackHDS ds - (DocCommentNamed _s ds) -> unpackHDS ds - (DocGroup _i ds) -> unpackHDS ds - in - printStringAdvance str + exact v = case v of + (DocCommentNext ds) -> exact ds + (DocCommentPrev ds) -> exact ds + (DocCommentNamed _s ds) -> exact ds + (DocGroup _i ds) -> exact ds -- --------------------------------------------------------------------- @@ -3044,9 +3053,9 @@ instance (ExactPrint a) => ExactPrint (LocatedC a) where -- Just (UnicodeSyntax, rs) -> markKw' AnnDarrowU rs -- Just (NormalSyntax, rs) -> markKw' AnnDarrow rs -- Nothing -> pure () - mapM_ (markKwA AnnOpenP) (sort opens) + mapM_ (markKwA AnnOpenP) (sortBy (comparing unsafeGetEpaLoc) opens) markAnnotated a - mapM_ (markKwA AnnCloseP) (sort closes) + mapM_ (markKwA AnnCloseP) (sortBy (comparing unsafeGetEpaLoc) closes) case ma of Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r Just (NormalSyntax, r) -> markKwA AnnDarrow r @@ -3136,7 +3145,11 @@ markTrailing :: [TrailingAnn] -> EPP () markTrailing ts = do p <- getPosP debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) - mapM_ markKwT (sort ts) + mapM_ markKwT (sortBy (comparing (unsafeGetEpaLoc . k)) ts) + where + k (AddSemiAnn l) = l + k (AddCommaAnn l) = l + k (AddVbarAnn l) = l -- --------------------------------------------------------------------- diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index f0617f3bfc..d170e5e945 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -32,8 +32,6 @@ import Parsers import GHC.Parser.Lexer import GHC.Data.FastString -import GHC.Types.SrcLoc - -- --------------------------------------------------------------------- @@ -276,9 +274,6 @@ main = do _ -> putStrLn usage deriving instance Data Token -deriving instance Data PsSpan -deriving instance Data BufSpan -deriving instance Data BufPos writeBinFile :: FilePath -> String -> IO() writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h x) diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index f59359a61d..d6ea9a627d 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -119,7 +119,7 @@ import GHC.Data.Bag import GHC.Data.FastString import Data.Data -import Data.List (sort, sortBy, find) +import Data.List (sortBy, sortOn, find) import Data.Maybe import qualified Data.Map as Map @@ -472,7 +472,7 @@ setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp (EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments [])) l) a setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp - = case sort (priorComments cs) of + = case sortAnchorLocated (priorComments cs) of [] -> L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor dp)) an cs) @@ -631,11 +631,11 @@ balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do -- + move the trailing ones to the last match. let split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf) - split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sort $ priorComments split)) + split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortAnchorLocated $ priorComments split)) - before = sort $ priorComments split2 - middle = sort $ getFollowingComments split2 - after = sort $ getFollowingComments split + before = sortAnchorLocated $ priorComments split2 + middle = sortAnchorLocated $ getFollowingComments split2 + after = sortAnchorLocated $ getFollowingComments split lf' = setCommentsSrcAnn lf (EpaComments before) logTr $ "balanceCommentsFB (before, after): " ++ showAst (before, after) @@ -736,7 +736,7 @@ balanceComments' la1 la2 = do logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) logTr $ "balanceComments': (anc1)=" ++ showAst (anc1) logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s) - logTr $ "balanceComments': (sort cs1f)=" ++ showAst (sort cs1f) + logTr $ "balanceComments': (sort cs1f)=" ++ showAst (sortOn fst cs1f) logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move) logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2') return (la1', la2') @@ -762,8 +762,8 @@ balanceComments' la1 la2 = do -- Need to also check for comments more closely attached to la1, -- ie trailing on the same line (move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay'')) - move = sort $ map snd (cs1move ++ move'' ++ move') - stay = sort $ map snd (cs1stay ++ stay') + move = sortAnchorLocated $ map snd (cs1move ++ move'' ++ move') + stay = sortAnchorLocated $ map snd (cs1stay ++ stay') an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move) an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f)) @@ -785,7 +785,7 @@ trailingCommentsDeltas anc (la@(L l _):las) -- AZ:TODO: this is identical to commentsDeltas priorCommentsDeltas :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] -priorCommentsDeltas anc cs = go anc (reverse $ sort cs) +priorCommentsDeltas anc cs = go anc (reverse $ sortAnchorLocated cs) where go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] go _ [] = [] @@ -839,8 +839,8 @@ moveLeadingComments (L la a) lb = (L la' a, lb') `debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb')) where split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la) - before = sort $ priorComments split - after = sort $ getFollowingComments split + before = sortAnchorLocated $ priorComments split + after = sortAnchorLocated $ getFollowingComments split -- TODO: need to set an entry delta on lb' to zero, and move the -- original spacing to the first comment. @@ -917,7 +917,7 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do gac = addCommentOrigDeltas $ epAnnComments ga gfc = getFollowingComments gac - gac' = setFollowingComments gac (sort $ gfc ++ move) + gac' = setFollowingComments gac (sortAnchorLocated $ gfc ++ move) ga' = (EpAnn anc an gac') an1' = setCommentsSrcAnn la cs1 diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index a9b7640107..4f94222370 100644 --- a/utils/check-exact/Utils.hs +++ b/utils/check-exact/Utils.hs @@ -237,10 +237,7 @@ insertCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- ghcCommentText :: LEpaComment -> String -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNext s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentPrev s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNamed s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocSection _ s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index a3bdfc8fd7..457d519143 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -259,6 +259,7 @@ gen_hs_source (Info defaults entries) = -- and we don't want a complaint that the constraint is redundant -- Remember, this silly file is only for Haddock's consumption + ++ "{-# OPTIONS_HADDOCK print-explicit-runtime-reps #-}" ++ "module GHC.Prim (\n" ++ unlines (map ((" " ++) . hdr) entries') ++ ") where\n" diff --git a/utils/haddock b/utils/haddock -Subproject b02188ab1cc46dd82395a22b04f890cf15f3fea +Subproject d2779a3e659d4e9f7044c346a566e5fe4edbdb9 |