diff options
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 |