[Git][ghc/ghc][wip/split-ghc-base] 2 commits: testsuite: Add test to catch changes in core libraries
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri May 19 20:54:57 UTC 2023
Ben Gamari pushed to branch wip/split-ghc-base at Glasgow Haskell Compiler / GHC
Commits:
921e16a2 by Ben Gamari at 2023-05-19T16:20:45-04:00
testsuite: Add test to catch changes in core libraries
This adds testing infrastructure to ensure that changes in core
libraries (e.g. `base` and `ghc-prim`) are caught in CI.
- - - - -
67252ef1 by Ben Gamari at 2023-05-19T16:40:19-04:00
base: Break up GHC.Base
- - - - -
22 changed files:
- compiler/GHC/Builtin/Names.hs
- hadrian/src/Packages.hs
- hadrian/src/Rules/Test.hs
- hadrian/src/Settings/Default.hs
- libraries/base/Data/Semigroup/Internal.hs-boot
- libraries/base/GHC/Base.hs
- + libraries/base/GHC/Base/FunOps.hs
- + libraries/base/GHC/Base/Functor.hs
- + libraries/base/GHC/Base/List.hs
- + libraries/base/GHC/Base/NonEmpty.hs
- + libraries/base/GHC/Base/Semigroup.hs
- libraries/base/GHC/Base.hs-boot → libraries/base/GHC/Base/Semigroup.hs-boot
- + libraries/base/GHC/Base/String.hs
- + libraries/base/GHC/Base/Void.hs
- libraries/base/base.cabal
- testsuite/mk/boilerplate.mk
- + testsuite/tests/interface-stability/Makefile
- + testsuite/tests/interface-stability/README.mkd
- + testsuite/tests/interface-stability/all.T
- + testsuite/tests/interface-stability/base-exports.stdout
- + utils/dump-decls/Main.hs
- + utils/dump-decls/dump-decls.cabal
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -549,7 +549,10 @@ pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_PRIM_PANIC,
gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT,
- gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
+ gHC_CLASSES, gHC_PRIMOPWRAPPERS,
+ gHC_BASE, gHC_BASE_FUNOPS, gHC_BASE_FUNCTOR, gHC_BASE_LIST, gHC_BASE_NONEMPTY,
+ gHC_BASE_SEMIGROUP, gHC_BASE_STRING, gHC_BASE_VOID,
+ gHC_ENUM,
gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,
gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,
@@ -574,7 +577,14 @@ gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes")
gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers")
-gHC_BASE = mkBaseModule (fsLit "GHC.Base")
+gHC_BASE = mkBaseModule (fsLit "GHC.Base")
+gHC_BASE_FUNOPS = mkBaseModule (fsLit "GHC.Base.FunOps")
+gHC_BASE_FUNCTOR = mkBaseModule (fsLit "GHC.Base.Functor")
+gHC_BASE_LIST = mkBaseModule (fsLit "GHC.Base.List")
+gHC_BASE_NONEMPTY = mkBaseModule (fsLit "GHC.Base.NonEmpty")
+gHC_BASE_SEMIGROUP = mkBaseModule (fsLit "GHC.Base.Semigroup")
+gHC_BASE_STRING = mkBaseModule (fsLit "GHC.Base.String")
+gHC_BASE_VOID = mkBaseModule (fsLit "GHC.Base.Void")
gHC_ENUM = mkBaseModule (fsLit "GHC.Enum")
gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi")
gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers")
@@ -786,7 +796,7 @@ fromListN_RDR = nameRdrName fromListNName
toList_RDR = nameRdrName toListName
compose_RDR :: RdrName
-compose_RDR = varQual_RDR gHC_BASE (fsLit ".")
+compose_RDR = varQual_RDR gHC_BASE_FUNOPS (fsLit ".")
not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,
and_RDR, range_RDR, inRange_RDR, index_RDR,
@@ -915,10 +925,10 @@ fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,
foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,
mappend_RDR :: RdrName
fmap_RDR = nameRdrName fmapName
-replace_RDR = varQual_RDR gHC_BASE (fsLit "<$")
+replace_RDR = varQual_RDR gHC_BASE_FUNCTOR (fsLit "<$")
pure_RDR = nameRdrName pureAName
ap_RDR = nameRdrName apAName
-liftA2_RDR = varQual_RDR gHC_BASE (fsLit "liftA2")
+liftA2_RDR = varQual_RDR gHC_BASE_FUNCTOR (fsLit "liftA2")
foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr")
foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap")
null_RDR = varQual_RDR dATA_FOLDABLE (fsLit "null")
@@ -972,7 +982,7 @@ leftDataConName = dcQual dATA_EITHER (fsLit "Left") leftDataConKey
rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey
voidTyConName :: Name
-voidTyConName = tcQual gHC_BASE (fsLit "Void") voidTyConKey
+voidTyConName = tcQual gHC_BASE_VOID (fsLit "Void") voidTyConKey
-- Generics (types)
v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
@@ -1054,7 +1064,7 @@ unpackCStringName, unpackCStringFoldrName,
unpackCStringAppendName, unpackCStringAppendUtf8Name,
eqStringName, cstringLengthName :: Name
cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey
-eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey
+eqStringName = varQual gHC_BASE_STRING (fsLit "eqString") eqStringIdKey
unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
@@ -1075,15 +1085,15 @@ eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey
eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey
ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey
geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey
-functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey
-fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey
+functorClassName = clsQual gHC_BASE_FUNCTOR (fsLit "Functor") functorClassKey
+fmapName = varQual gHC_BASE_FUNCTOR (fsLit "fmap") fmapClassOpKey
-- Class Monad
monadClassName, thenMName, bindMName, returnMName :: Name
-monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey
-thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey
-bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey
-returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey
+monadClassName = clsQual gHC_BASE_FUNCTOR (fsLit "Monad") monadClassKey
+thenMName = varQual gHC_BASE_FUNCTOR (fsLit ">>") thenMClassOpKey
+bindMName = varQual gHC_BASE_FUNCTOR (fsLit ">>=") bindMClassOpKey
+returnMName = varQual gHC_BASE_FUNCTOR (fsLit "return") returnMClassOpKey
-- Class MonadFail
monadFailClassName, failMName :: Name
@@ -1092,10 +1102,10 @@ failMName = varQual mONAD_FAIL (fsLit "fail") failMClassOpKey
-- Class Applicative
applicativeClassName, pureAName, apAName, thenAName :: Name
-applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey
-apAName = varQual gHC_BASE (fsLit "<*>") apAClassOpKey
-pureAName = varQual gHC_BASE (fsLit "pure") pureAClassOpKey
-thenAName = varQual gHC_BASE (fsLit "*>") thenAClassOpKey
+applicativeClassName = clsQual gHC_BASE_FUNCTOR (fsLit "Applicative") applicativeClassKey
+apAName = varQual gHC_BASE_FUNCTOR (fsLit "<*>") apAClassOpKey
+pureAName = varQual gHC_BASE_FUNCTOR (fsLit "pure") pureAClassOpKey
+thenAName = varQual gHC_BASE_FUNCTOR (fsLit "*>") thenAClassOpKey
-- Classes (Foldable, Traversable)
foldableClassName, traversableClassName :: Name
@@ -1104,20 +1114,20 @@ traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") trave
-- Classes (Semigroup, Monoid)
semigroupClassName, sappendName :: Name
-semigroupClassName = clsQual gHC_BASE (fsLit "Semigroup") semigroupClassKey
-sappendName = varQual gHC_BASE (fsLit "<>") sappendClassOpKey
+semigroupClassName = clsQual gHC_BASE_SEMIGROUP (fsLit "Semigroup") semigroupClassKey
+sappendName = varQual gHC_BASE_SEMIGROUP (fsLit "<>") sappendClassOpKey
monoidClassName, memptyName, mappendName, mconcatName :: Name
-monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey
-memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey
-mappendName = varQual gHC_BASE (fsLit "mappend") mappendClassOpKey
-mconcatName = varQual gHC_BASE (fsLit "mconcat") mconcatClassOpKey
+monoidClassName = clsQual gHC_BASE_SEMIGROUP (fsLit "Monoid") monoidClassKey
+memptyName = varQual gHC_BASE_SEMIGROUP (fsLit "mempty") memptyClassOpKey
+mappendName = varQual gHC_BASE_SEMIGROUP (fsLit "mappend") mappendClassOpKey
+mconcatName = varQual gHC_BASE_SEMIGROUP (fsLit "mconcat") mconcatClassOpKey
-- AMP additions
joinMName, alternativeClassName :: Name
-joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey
+joinMName = varQual gHC_BASE_FUNCTOR (fsLit "join") joinMIdKey
alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey
--
@@ -1138,13 +1148,13 @@ considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerA
fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
mapName, appendName, assertName,
dollarName :: Name
-dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey
+dollarName = varQual gHC_BASE_FUNOPS (fsLit "$") dollarIdKey
otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey
-foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey
-buildName = varQual gHC_BASE (fsLit "build") buildIdKey
-augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey
-mapName = varQual gHC_BASE (fsLit "map") mapIdKey
-appendName = varQual gHC_BASE (fsLit "++") appendIdKey
+foldrName = varQual gHC_BASE_LIST (fsLit "foldr") foldrIdKey
+buildName = varQual gHC_BASE_LIST (fsLit "build") buildIdKey
+augmentName = varQual gHC_BASE_LIST (fsLit "augment") augmentIdKey
+mapName = varQual gHC_BASE_LIST (fsLit "map") mapIdKey
+appendName = varQual gHC_BASE_LIST (fsLit "++") appendIdKey
assertName = varQual gHC_BASE (fsLit "assert") assertIdKey
fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey
@@ -1431,7 +1441,7 @@ withDictClassName :: Name
withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey
nonEmptyTyConName :: Name
-nonEmptyTyConName = tcQual gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey
+nonEmptyTyConName = tcQual gHC_BASE_NONEMPTY (fsLit "NonEmpty") nonEmptyTyConKey
-- Custom type errors
errorMessageTypeErrorFamName
@@ -1546,10 +1556,10 @@ ioTyConName, ioDataConName,
thenIOName, bindIOName, returnIOName, failIOName :: Name
ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey
ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey
-thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey
-bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey
-returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey
-failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey
+thenIOName = varQual gHC_BASE_FUNCTOR (fsLit "thenIO") thenIOIdKey
+bindIOName = varQual gHC_BASE_FUNCTOR (fsLit "bindIO") bindIOIdKey
+returnIOName = varQual gHC_BASE_FUNCTOR (fsLit "returnIO") returnIOIdKey
+failIOName = varQual gHC_BASE_FUNCTOR (fsLit "failIO") failIOIdKey
-- IO things
printName :: Name
=====================================
hadrian/src/Packages.hs
=====================================
@@ -3,7 +3,7 @@ module Packages (
-- * GHC packages
array, base, binary, bytestring, cabal, cabalSyntax, checkPpr,
checkExact, countDeps,
- compareSizes, compiler, containers, deepseq, deriveConstants, directory,
+ compareSizes, compiler, containers, deepseq, deriveConstants, directory, dumpDecls,
exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh,
ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline,
hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy,
@@ -35,7 +35,7 @@ import Oracles.Setting
ghcPackages :: [Package]
ghcPackages =
[ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps
- , compareSizes, compiler, containers, deepseq, deriveConstants, directory
+ , compareSizes, compiler, containers, deepseq, deriveConstants, directory, dumpDecls
, exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh
, ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs
, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, mtl
@@ -51,7 +51,7 @@ isGhcPackage = (`elem` ghcPackages)
-- | Package definitions, see 'Package'.
array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps,
- compareSizes, compiler, containers, deepseq, deriveConstants, directory,
+ compareSizes, compiler, containers, deepseq, deriveConstants, directory, dumpDecls,
exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh,
ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs,
hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, mtl,
@@ -75,6 +75,7 @@ containers = lib "containers" `setPath` "libraries/containers/con
deepseq = lib "deepseq"
deriveConstants = util "deriveConstants"
directory = lib "directory"
+dumpDecls = util "dump-decls"
exceptions = lib "exceptions"
filepath = lib "filepath"
genapply = util "genapply"
=====================================
hadrian/src/Rules/Test.hs
=====================================
@@ -40,6 +40,12 @@ countDepsSourcePath = "utils/count-deps/Main.hs"
countDepsExtra :: [String]
countDepsExtra = ["-iutils/count-deps"]
+dumpDeclsProgPath, dumpDeclsSourcePath :: FilePath
+dumpDeclsProgPath = "test/bin/dump-decls" <.> exe
+dumpDeclsSourcePath = "utils/dump-decls/Main.hs"
+dumpDeclsExtra :: [String]
+dumpDeclsExtra = []
+
noteLinterProgPath, noteLinterSourcePath :: FilePath
noteLinterProgPath = "test/bin/lint-notes" <.> exe
noteLinterSourcePath = "linters/lint-notes/Main.hs"
@@ -67,6 +73,7 @@ checkPrograms =
[ CheckProgram "test:check-ppr" checkPprProgPath checkPprSourcePath checkPprExtra checkPpr id id
, CheckProgram "test:check-exact" checkExactProgPath checkExactSourcePath checkExactExtra checkExact id id
, CheckProgram "test:count-deps" countDepsProgPath countDepsSourcePath countDepsExtra countDeps id id
+ , CheckProgram "test:dump-decls" dumpDeclsProgPath dumpDeclsSourcePath dumpDeclsExtra dumpDecls id id
, CheckProgram "lint:notes" noteLinterProgPath noteLinterSourcePath noteLinterExtra lintNotes (const stage0Boot) id
, CheckProgram "lint:whitespace" whitespaceLinterProgPath whitespaceLinterSourcePath whitespaceLinterExtra lintWhitespace (const stage0Boot) (filter (/= lintersCommon))
]
@@ -260,6 +267,7 @@ testRules = do
setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath)
setEnv "CHECK_EXACT" (top -/- root -/- checkExactProgPath)
+ setEnv "DUMP_DECLS" (top -/- root -/- dumpDeclsProgPath)
setEnv "COUNT_DEPS" (top -/- root -/- countDepsProgPath)
setEnv "LINT_NOTES" (top -/- root -/- noteLinterProgPath)
setEnv "LINT_WHITESPACE" (top -/- root -/- whitespaceLinterProgPath)
=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -167,7 +167,7 @@ stage2Packages = stage1Packages
-- | Packages that are built only for the testsuite.
testsuitePackages :: Action [Package]
-testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact, countDeps, ghcConfig ])
+testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact, countDeps, ghcConfig, dumpDecls ])
-- | Default build ways for library packages:
-- * We always build 'vanilla' way.
=====================================
libraries/base/Data/Semigroup/Internal.hs-boot
=====================================
@@ -3,7 +3,8 @@
module Data.Semigroup.Internal where
import {-# SOURCE #-} GHC.Real (Integral)
-import {-# SOURCE #-} GHC.Base (Semigroup,Monoid,Maybe)
+import {-# SOURCE #-} GHC.Base.Semigroup (Semigroup,Monoid)
+import GHC.Maybe (Maybe)
import GHC.Num.Integer () -- See Note [Depend on GHC.Num.Integer] in GHC.Base
stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a
=====================================
libraries/base/GHC/Base.hs
=====================================
@@ -75,9 +75,6 @@ Other Prelude modules are much easier with fewer complex dependencies.
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE Unsafe #-}
--- -Wno-orphans is needed for things like:
--- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0
-{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_HADDOCK not-home #-}
-----------------------------------------------------------------------------
@@ -97,20 +94,24 @@ Other Prelude modules are much easier with fewer complex dependencies.
#include "MachDeps.h"
module GHC.Base
- (
- module GHC.Base,
- module GHC.Classes,
- module GHC.CString,
- module GHC.Magic,
- module GHC.Magic.Dict,
- module GHC.Types,
- module GHC.Prim, -- Re-export GHC.Prim, GHC.Prim.Ext,
- module GHC.Prim.Ext, -- GHC.Prim.PtrEq and [boot] GHC.Err
- module GHC.Prim.PtrEq, -- to avoid lots of people having to
- module GHC.Err, -- import these modules explicitly
- module GHC.Maybe
- )
- where
+ ( module GHC.Base
+ , module GHC.Base.FunOps
+ , module GHC.Base.Functor
+ , module GHC.Base.List
+ , module GHC.Base.NonEmpty
+ , module GHC.Base.Semigroup
+ , module GHC.Base.String
+ , module GHC.Base.Void
+ , module GHC.Classes
+ , module GHC.CString
+ , module GHC.Magic
+ , module GHC.Magic.Dict , module GHC.Types
+ , module GHC.Prim -- Re-export GHC.Prim, GHC.Prim.Ext,
+ , module GHC.Prim.Ext -- GHC.Prim.PtrEq and [boot] GHC.Err
+ , module GHC.Prim.PtrEq -- to avoid lots of people having to
+ , module GHC.Err -- import these modules explicitly
+ , module GHC.Maybe
+ ) where
import GHC.Types
import GHC.Classes
@@ -122,31 +123,20 @@ import GHC.Prim.Ext
import GHC.Prim.PtrEq
import GHC.Err
import GHC.Maybe
-import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO)
-import GHC.Tuple (Solo (MkSolo)) -- Note [Depend on GHC.Tuple]
import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer]
--- for 'class Semigroup'
-import {-# SOURCE #-} GHC.Real (Integral)
-import {-# SOURCE #-} Data.Semigroup.Internal ( stimesDefault
- , stimesMaybe
- , stimesList
- , stimesIdempotentMonoid
- )
+import GHC.Base.FunOps
+import GHC.Base.Functor
+import GHC.Base.List
+import GHC.Base.NonEmpty
+import GHC.Base.Semigroup
+import GHC.Base.String
+import GHC.Base.Void
-- $setup
-- >>> import GHC.Num
-infixr 9 .
-infixr 5 ++
-infixl 4 <$
-infixl 1 >>, >>=
-infixr 1 =<<
-infixr 0 $, $!
-
-infixl 4 <*>, <*, *>, <**>
-
default () -- Double isn't available yet
{-
@@ -191,1296 +181,12 @@ data Char = C# Char#
type String = [Char]
data Int = I# Int#
data () = ()
-data [] a = MkNil
not True = False
(&&) True True = True
otherwise = True
-
-build = errorWithoutStackTrace "urk"
-foldr = errorWithoutStackTrace "urk"
#endif
--- | Uninhabited data type
---
--- @since 4.8.0.0
-data Void deriving
- ( Eq -- ^ @since 4.8.0.0
- , Ord -- ^ @since 4.8.0.0
- )
-
--- | Since 'Void' values logically don't exist, this witnesses the
--- logical reasoning tool of \"ex falso quodlibet\".
---
--- >>> let x :: Either Void Int; x = Right 5
--- >>> :{
--- case x of
--- Right r -> r
--- Left l -> absurd l
--- :}
--- 5
---
--- @since 4.8.0.0
-absurd :: Void -> a
-absurd a = case a of {}
-
--- | If 'Void' is uninhabited then any 'Functor' that holds only
--- values of type 'Void' is holding no values.
--- It is implemented in terms of @fmap absurd at .
---
--- @since 4.8.0.0
-vacuous :: Functor f => f Void -> f a
-vacuous = fmap absurd
-
-infixr 6 <>
-
--- | The class of semigroups (types with an associative binary operation).
---
--- Instances should satisfy the following:
---
--- [Associativity] @x '<>' (y '<>' z) = (x '<>' y) '<>' z@
---
--- You can alternatively define `sconcat` instead of (`<>`), in which case the
--- laws are:
---
--- [Unit]: @'sconcat' ('pure' x) = x@
--- [Multiplication]: @'sconcat' ('join' xss) = 'sconcat' ('fmap' 'sconcat' xss)@
---
--- @since 4.9.0.0
-class Semigroup a where
- -- | An associative operation.
- --
- -- >>> [1,2,3] <> [4,5,6]
- -- [1,2,3,4,5,6]
- (<>) :: a -> a -> a
- a <> b = sconcat (a :| [ b ])
-
- -- | Reduce a non-empty list with '<>'
- --
- -- The default definition should be sufficient, but this can be
- -- overridden for efficiency.
- --
- -- >>> import Data.List.NonEmpty (NonEmpty (..))
- -- >>> sconcat $ "Hello" :| [" ", "Haskell", "!"]
- -- "Hello Haskell!"
- sconcat :: NonEmpty a -> a
- sconcat (a :| as) = go a as where
- go b (c:cs) = b <> go c cs
- go b [] = b
-
- -- | Repeat a value @n@ times.
- --
- -- Given that this works on a 'Semigroup' it is allowed to fail if
- -- you request 0 or fewer repetitions, and the default definition
- -- will do so.
- --
- -- By making this a member of the class, idempotent semigroups
- -- and monoids can upgrade this to execute in \(\mathcal{O}(1)\) by
- -- picking @stimes = 'Data.Semigroup.stimesIdempotent'@ or @stimes =
- -- 'stimesIdempotentMonoid'@ respectively.
- --
- -- >>> stimes 4 [1]
- -- [1,1,1,1]
- stimes :: Integral b => b -> a -> a
- stimes = stimesDefault
-
- {-# MINIMAL (<>) | sconcat #-}
-
-
--- | The class of monoids (types with an associative binary operation that
--- has an identity). Instances should satisfy the following:
---
--- [Right identity] @x '<>' 'mempty' = x@
--- [Left identity] @'mempty' '<>' x = x@
--- [Associativity] @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ ('Semigroup' law)
--- [Concatenation] @'mconcat' = 'foldr' ('<>') 'mempty'@
---
--- You can alternatively define `mconcat` instead of `mempty`, in which case the
--- laws are:
---
--- [Unit]: @'mconcat' ('pure' x) = x@
--- [Multiplication]: @'mconcat' ('join' xss) = 'mconcat' ('fmap' 'mconcat' xss)@
--- [Subclass]: @'mconcat' ('toList' xs) = 'sconcat' xs@
---
--- The method names refer to the monoid of lists under concatenation,
--- but there are many other instances.
---
--- Some types can be viewed as a monoid in more than one way,
--- e.g. both addition and multiplication on numbers.
--- In such cases we often define @newtype at s and make those instances
--- of 'Monoid', e.g. 'Data.Semigroup.Sum' and 'Data.Semigroup.Product'.
---
--- __NOTE__: 'Semigroup' is a superclass of 'Monoid' since /base-4.11.0.0/.
-class Semigroup a => Monoid a where
- -- | Identity of 'mappend'
- --
- -- >>> "Hello world" <> mempty
- -- "Hello world"
- mempty :: a
- mempty = mconcat []
- {-# INLINE mempty #-}
-
- -- | An associative operation
- --
- -- __NOTE__: This method is redundant and has the default
- -- implementation @'mappend' = ('<>')@ since /base-4.11.0.0/.
- -- Should it be implemented manually, since 'mappend' is a synonym for
- -- ('<>'), it is expected that the two functions are defined the same
- -- way. In a future GHC release 'mappend' will be removed from 'Monoid'.
- mappend :: a -> a -> a
- mappend = (<>)
- {-# INLINE mappend #-}
-
- -- | Fold a list using the monoid.
- --
- -- For most types, the default definition for 'mconcat' will be
- -- used, but the function is included in the class definition so
- -- that an optimized version can be provided for specific types.
- --
- -- >>> mconcat ["Hello", " ", "Haskell", "!"]
- -- "Hello Haskell!"
- mconcat :: [a] -> a
- mconcat = foldr mappend mempty
- {-# INLINE mconcat #-}
- -- INLINE in the hope of fusion with mconcat's argument (see !4890)
-
- {-# MINIMAL mempty | mconcat #-}
-
--- | @since 4.9.0.0
-instance Semigroup [a] where
- (<>) = (++)
- {-# INLINE (<>) #-}
-
- stimes = stimesList
-
--- | @since 2.01
-instance Monoid [a] where
- {-# INLINE mempty #-}
- mempty = []
- {-# INLINE mconcat #-}
- mconcat xss = [x | xs <- xss, x <- xs]
--- See Note: [List comprehensions and inlining]
-
--- | @since 4.9.0.0
-instance Semigroup Void where
- a <> _ = a
- stimes _ a = a
-
-{-
-Note: [List comprehensions and inlining]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The list monad operations are traditionally described in terms of concatMap:
-
-xs >>= f = concatMap f xs
-
-Similarly, mconcat for lists is just concat. Here in Base, however, we don't
-have concatMap, and we'll refrain from adding it here so it won't have to be
-hidden in imports. Instead, we use GHC's list comprehension desugaring
-mechanism to define mconcat and the Applicative and Monad instances for lists.
-We mark them INLINE because the inliner is not generally too keen to inline
-build forms such as the ones these desugar to without our insistence. Defining
-these using list comprehensions instead of foldr has an additional potential
-benefit, as described in compiler/GHC/HsToCore/ListComp.hs: if optimizations
-needed to make foldr/build forms efficient are turned off, we'll get reasonably
-efficient translations anyway.
--}
-
--- | @since 4.9.0.0
-instance Semigroup (NonEmpty a) where
- (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs)
-
--- | @since 4.9.0.0
-instance Semigroup b => Semigroup (a -> b) where
- f <> g = \x -> f x <> g x
- stimes n f e = stimes n (f e)
-
--- | @since 2.01
-instance Monoid b => Monoid (a -> b) where
- mempty _ = mempty
- -- If `b` has a specialised mconcat, use that, rather than the default
- -- mconcat, which can be much less efficient. Inline in the hope that
- -- it may result in list fusion.
- mconcat = \fs x -> mconcat $ map (\f -> f x) fs
- {-# INLINE mconcat #-}
-
--- | @since 4.9.0.0
-instance Semigroup () where
- _ <> _ = ()
- sconcat _ = ()
- stimes _ _ = ()
-
--- | @since 2.01
-instance Monoid () where
- -- Should it be strict?
- mempty = ()
- mconcat _ = ()
-
--- | @since 4.15
-instance Semigroup a => Semigroup (Solo a) where
- MkSolo a <> MkSolo b = MkSolo (a <> b)
- stimes n (MkSolo a) = MkSolo (stimes n a)
-
--- | @since 4.15
-instance Monoid a => Monoid (Solo a) where
- mempty = MkSolo mempty
-
--- | @since 4.9.0.0
-instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
- (a,b) <> (a',b') = (a<>a',b<>b')
- stimes n (a,b) = (stimes n a, stimes n b)
-
--- | @since 2.01
-instance (Monoid a, Monoid b) => Monoid (a,b) where
- mempty = (mempty, mempty)
-
--- | @since 4.9.0.0
-instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where
- (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')
- stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)
-
--- | @since 2.01
-instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
- mempty = (mempty, mempty, mempty)
-
--- | @since 4.9.0.0
-instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)
- => Semigroup (a, b, c, d) where
- (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')
- stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)
-
--- | @since 2.01
-instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
- mempty = (mempty, mempty, mempty, mempty)
-
--- | @since 4.9.0.0
-instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
- => Semigroup (a, b, c, d, e) where
- (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
- stimes n (a,b,c,d,e) =
- (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)
-
--- | @since 2.01
-instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
- Monoid (a,b,c,d,e) where
- mempty = (mempty, mempty, mempty, mempty, mempty)
-
-
--- | @since 4.9.0.0
-instance Semigroup Ordering where
- LT <> _ = LT
- EQ <> y = y
- GT <> _ = GT
-
- stimes = stimesIdempotentMonoid
-
--- lexicographical ordering
--- | @since 2.01
-instance Monoid Ordering where
- mempty = EQ
-
--- | @since 4.9.0.0
-instance Semigroup a => Semigroup (Maybe a) where
- Nothing <> b = b
- a <> Nothing = a
- Just a <> Just b = Just (a <> b)
-
- stimes = stimesMaybe
-
--- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
--- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
--- turned into a monoid simply by adjoining an element @e@ not in @S@
--- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S at .\"
---
--- /Since 4.11.0/: constraint on inner @a@ value generalised from
--- 'Monoid' to 'Semigroup'.
---
--- @since 2.01
-instance Semigroup a => Monoid (Maybe a) where
- mempty = Nothing
-
--- | @since 4.15
-instance Applicative Solo where
- pure = MkSolo
-
- -- Note: we really want to match strictly here. This lets us write,
- -- for example,
- --
- -- forceSpine :: Foldable f => f a -> ()
- -- forceSpine xs
- -- | MkSolo r <- traverse_ MkSolo xs
- -- = r
- MkSolo f <*> MkSolo x = MkSolo (f x)
- liftA2 f (MkSolo x) (MkSolo y) = MkSolo (f x y)
-
--- | For tuples, the 'Monoid' constraint on @a@ determines
--- how the first values merge.
--- For example, 'String's concatenate:
---
--- > ("hello ", (+15)) <*> ("world!", 2002)
--- > ("hello world!",2017)
---
--- @since 2.01
-instance Monoid a => Applicative ((,) a) where
- pure x = (mempty, x)
- (u, f) <*> (v, x) = (u <> v, f x)
- liftA2 f (u, x) (v, y) = (u <> v, f x y)
-
--- | @since 4.15
-instance Monad Solo where
- MkSolo x >>= f = f x
-
--- | @since 4.9.0.0
-instance Monoid a => Monad ((,) a) where
- (u, a) >>= k = case k a of (v, b) -> (u <> v, b)
-
--- | @since 4.14.0.0
-instance Functor ((,,) a b) where
- fmap f (a, b, c) = (a, b, f c)
-
--- | @since 4.14.0.0
-instance (Monoid a, Monoid b) => Applicative ((,,) a b) where
- pure x = (mempty, mempty, x)
- (a, b, f) <*> (a', b', x) = (a <> a', b <> b', f x)
-
--- | @since 4.14.0.0
-instance (Monoid a, Monoid b) => Monad ((,,) a b) where
- (u, v, a) >>= k = case k a of (u', v', b) -> (u <> u', v <> v', b)
-
--- | @since 4.14.0.0
-instance Functor ((,,,) a b c) where
- fmap f (a, b, c, d) = (a, b, c, f d)
-
--- | @since 4.14.0.0
-instance (Monoid a, Monoid b, Monoid c) => Applicative ((,,,) a b c) where
- pure x = (mempty, mempty, mempty, x)
- (a, b, c, f) <*> (a', b', c', x) = (a <> a', b <> b', c <> c', f x)
-
--- | @since 4.14.0.0
-instance (Monoid a, Monoid b, Monoid c) => Monad ((,,,) a b c) where
- (u, v, w, a) >>= k = case k a of (u', v', w', b) -> (u <> u', v <> v', w <> w', b)
-
--- | @since 4.18.0.0
-instance Functor ((,,,,) a b c d) where
- fmap f (a, b, c, d, e) = (a, b, c, d, f e)
-
--- | @since 4.18.0.0
-instance Functor ((,,,,,) a b c d e) where
- fmap fun (a, b, c, d, e, f) = (a, b, c, d, e, fun f)
-
--- | @since 4.18.0.0
-instance Functor ((,,,,,,) a b c d e f) where
- fmap fun (a, b, c, d, e, f, g) = (a, b, c, d, e, f, fun g)
-
--- | @since 4.10.0.0
-instance Semigroup a => Semigroup (IO a) where
- (<>) = liftA2 (<>)
-
--- | @since 4.9.0.0
-instance Monoid a => Monoid (IO a) where
- mempty = pure mempty
-
-{- | A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@
-lets you apply any function from @(a -> b)@ to turn an @f a@ into an @f b@, preserving the
-structure of @f at . Furthermore @f@ needs to adhere to the following:
-
-[Identity] @'fmap' 'id' == 'id'@
-[Composition] @'fmap' (f . g) == 'fmap' f . 'fmap' g@
-
-Note, that the second law follows from the free theorem of the type 'fmap' and
-the first law, so you need only check that the former condition holds.
-See <https://www.schoolofhaskell.com/user/edwardk/snippets/fmap> or
-<https://github.com/quchen/articles/blob/master/second_functor_law.md>
-for an explanation.
--}
-
-class Functor f where
- -- | 'fmap' is used to apply a function of type @(a -> b)@ to a value of type @f a@,
- -- where f is a functor, to produce a value of type @f b at .
- -- Note that for any type constructor with more than one parameter (e.g., `Either`),
- -- only the last type parameter can be modified with `fmap` (e.g., `b` in `Either a b`).
- --
- -- Some type constructors with two parameters or more have a @'Data.Bifunctor'@ instance that allows
- -- both the last and the penultimate parameters to be mapped over.
- --
- -- ==== __Examples__
- --
- -- Convert from a @'Data.Maybe.Maybe' Int@ to a @Maybe String@
- -- using 'Prelude.show':
- --
- -- >>> fmap show Nothing
- -- Nothing
- -- >>> fmap show (Just 3)
- -- Just "3"
- --
- -- Convert from an @'Data.Either.Either' Int Int@ to an
- -- @Either Int String@ using 'Prelude.show':
- --
- -- >>> fmap show (Left 17)
- -- Left 17
- -- >>> fmap show (Right 17)
- -- Right "17"
- --
- -- Double each element of a list:
- --
- -- >>> fmap (*2) [1,2,3]
- -- [2,4,6]
- --
- -- Apply 'Prelude.even' to the second element of a pair:
- --
- -- >>> fmap even (2,2)
- -- (2,True)
- --
- -- It may seem surprising that the function is only applied to the last element of the tuple
- -- compared to the list example above which applies it to every element in the list.
- -- To understand, remember that tuples are type constructors with multiple type parameters:
- -- a tuple of 3 elements @(a,b,c)@ can also be written @(,,) a b c@ and its @Functor@ instance
- -- is defined for @Functor ((,,) a b)@ (i.e., only the third parameter is free to be mapped over
- -- with @fmap@).
- --
- -- It explains why @fmap@ can be used with tuples containing values of different types as in the
- -- following example:
- --
- -- >>> fmap even ("hello", 1.0, 4)
- -- ("hello",1.0,True)
-
- fmap :: (a -> b) -> f a -> f b
-
- -- | Replace all locations in the input with the same value.
- -- The default definition is @'fmap' . 'const'@, but this may be
- -- overridden with a more efficient version.
- --
- -- ==== __Examples__
- --
- -- Perform a computation with 'Maybe' and replace the result with a
- -- constant value if it is 'Just':
- --
- -- >>> 'a' <$ Just 2
- -- Just 'a'
- -- >>> 'a' <$ Nothing
- -- Nothing
- (<$) :: a -> f b -> f a
- (<$) = fmap . const
-
--- | A functor with application, providing operations to
---
--- * embed pure expressions ('pure'), and
---
--- * sequence computations and combine their results ('<*>' and 'liftA2').
---
--- A minimal complete definition must include implementations of 'pure'
--- and of either '<*>' or 'liftA2'. If it defines both, then they must behave
--- the same as their default definitions:
---
--- @('<*>') = 'liftA2' 'id'@
---
--- @'liftA2' f x y = f 'Prelude.<$>' x '<*>' y@
---
--- Further, any definition must satisfy the following:
---
--- [Identity]
---
--- @'pure' 'id' '<*>' v = v@
---
--- [Composition]
---
--- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
---
--- [Homomorphism]
---
--- @'pure' f '<*>' 'pure' x = 'pure' (f x)@
---
--- [Interchange]
---
--- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
---
---
--- The other methods have the following default definitions, which may
--- be overridden with equivalent specialized implementations:
---
--- * @u '*>' v = ('id' '<$' u) '<*>' v@
---
--- * @u '<*' v = 'liftA2' 'const' u v@
---
--- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
---
--- * @'fmap' f x = 'pure' f '<*>' x@
---
---
--- It may be useful to note that supposing
---
--- @forall x y. p (q x y) = f x . g y@
---
--- it follows from the above that
---
--- @'liftA2' p ('liftA2' q u v) = 'liftA2' f u . 'liftA2' g v@
---
---
--- If @f@ is also a 'Monad', it should satisfy
---
--- * @'pure' = 'return'@
---
--- * @m1 '<*>' m2 = m1 '>>=' (\\x1 -> m2 '>>=' (\\x2 -> 'return' (x1 x2)))@
---
--- * @('*>') = ('>>')@
---
--- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
-
-class Functor f => Applicative f where
- {-# MINIMAL pure, ((<*>) | liftA2) #-}
- -- | Lift a value.
- pure :: a -> f a
-
- -- | Sequential application.
- --
- -- A few functors support an implementation of '<*>' that is more
- -- efficient than the default one.
- --
- -- ==== __Example__
- -- Used in combination with @('<$>')@, @('<*>')@ can be used to build a record.
- --
- -- >>> data MyState = MyState {arg1 :: Foo, arg2 :: Bar, arg3 :: Baz}
- --
- -- >>> produceFoo :: Applicative f => f Foo
- --
- -- >>> produceBar :: Applicative f => f Bar
- -- >>> produceBaz :: Applicative f => f Baz
- --
- -- >>> mkState :: Applicative f => f MyState
- -- >>> mkState = MyState <$> produceFoo <*> produceBar <*> produceBaz
- (<*>) :: f (a -> b) -> f a -> f b
- (<*>) = liftA2 id
-
- -- | Lift a binary function to actions.
- --
- -- Some functors support an implementation of 'liftA2' that is more
- -- efficient than the default one. In particular, if 'fmap' is an
- -- expensive operation, it is likely better to use 'liftA2' than to
- -- 'fmap' over the structure and then use '<*>'.
- --
- -- This became a typeclass method in 4.10.0.0. Prior to that, it was
- -- a function defined in terms of '<*>' and 'fmap'.
- --
- -- ==== __Example__
- -- >>> liftA2 (,) (Just 3) (Just 5)
- -- Just (3,5)
-
- liftA2 :: (a -> b -> c) -> f a -> f b -> f c
- liftA2 f x = (<*>) (fmap f x)
-
- -- | Sequence actions, discarding the value of the first argument.
- --
- -- ==== __Examples__
- -- If used in conjunction with the Applicative instance for 'Maybe',
- -- you can chain Maybe computations, with a possible "early return"
- -- in case of 'Nothing'.
- --
- -- >>> Just 2 *> Just 3
- -- Just 3
- --
- -- >>> Nothing *> Just 3
- -- Nothing
- --
- -- Of course a more interesting use case would be to have effectful
- -- computations instead of just returning pure values.
- --
- -- >>> import Data.Char
- -- >>> import Text.ParserCombinators.ReadP
- -- >>> let p = string "my name is " *> munch1 isAlpha <* eof
- -- >>> readP_to_S p "my name is Simon"
- -- [("Simon","")]
-
- (*>) :: f a -> f b -> f b
- a1 *> a2 = (id <$ a1) <*> a2
-
- -- This is essentially the same as liftA2 (flip const), but if the
- -- Functor instance has an optimized (<$), it may be better to use
- -- that instead. Before liftA2 became a method, this definition
- -- was strictly better, but now it depends on the functor. For a
- -- functor supporting a sharing-enhancing (<$), this definition
- -- may reduce allocation by preventing a1 from ever being fully
- -- realized. In an implementation with a boring (<$) but an optimizing
- -- liftA2, it would likely be better to define (*>) using liftA2.
-
- -- | Sequence actions, discarding the value of the second argument.
- --
- (<*) :: f a -> f b -> f a
- (<*) = liftA2 const
-
--- | A variant of '<*>' with the arguments reversed.
---
-(<**>) :: Applicative f => f a -> f (a -> b) -> f b
-(<**>) = liftA2 (\a f -> f a)
--- Don't use $ here, see the note at the top of the page
-
--- | Lift a function to actions.
--- Equivalent to Functor's `fmap` but implemented using only `Applicative`'s methods:
--- @'liftA' f a = 'pure' f '<*>' a@
---
--- As such this function may be used to implement a `Functor` instance from an `Applicative` one.
---
--- ==== __Examples__
--- Using the Applicative instance for Lists:
---
--- >>> liftA (+1) [1, 2]
--- [2,3]
---
--- Or the Applicative instance for 'Maybe'
---
--- >>> liftA (+1) (Just 3)
--- Just 4
-
-liftA :: Applicative f => (a -> b) -> f a -> f b
-liftA f a = pure f <*> a
--- Caution: since this may be used for `fmap`, we can't use the obvious
--- definition of liftA = fmap.
-
--- | Lift a ternary function to actions.
-
-liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
-liftA3 f a b c = liftA2 f a b <*> c
-
-
-{-# INLINABLE liftA #-}
-{-# SPECIALISE liftA :: (a1->r) -> IO a1 -> IO r #-}
-{-# SPECIALISE liftA :: (a1->r) -> Maybe a1 -> Maybe r #-}
-{-# INLINABLE liftA3 #-}
-{-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
-{-# SPECIALISE liftA3 :: (a1->a2->a3->r) ->
- Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}
-
--- | The 'join' function is the conventional monad join operator. It
--- is used to remove one level of monadic structure, projecting its
--- bound argument into the outer level.
---
---
--- \'@'join' bss@\' can be understood as the @do@ expression
---
--- @
--- do bs <- bss
--- bs
--- @
---
--- ==== __Examples__
---
--- A common use of 'join' is to run an 'IO' computation returned from
--- an 'GHC.Conc.STM' transaction, since 'GHC.Conc.STM' transactions
--- can't perform 'IO' directly. Recall that
---
--- @
--- 'GHC.Conc.atomically' :: STM a -> IO a
--- @
---
--- is used to run 'GHC.Conc.STM' transactions atomically. So, by
--- specializing the types of 'GHC.Conc.atomically' and 'join' to
---
--- @
--- 'GHC.Conc.atomically' :: STM (IO b) -> IO (IO b)
--- 'join' :: IO (IO b) -> IO b
--- @
---
--- we can compose them as
---
--- @
--- 'join' . 'GHC.Conc.atomically' :: STM (IO b) -> IO b
--- @
---
--- to run an 'GHC.Conc.STM' transaction and the 'IO' action it
--- returns.
-join :: (Monad m) => m (m a) -> m a
-join x = x >>= id
-
-{- | The 'Monad' class defines the basic operations over a /monad/,
-a concept from a branch of mathematics known as /category theory/.
-From the perspective of a Haskell programmer, however, it is best to
-think of a monad as an /abstract datatype/ of actions.
-Haskell's @do@ expressions provide a convenient syntax for writing
-monadic expressions.
-
-Instances of 'Monad' should satisfy the following:
-
-[Left identity] @'return' a '>>=' k = k a@
-[Right identity] @m '>>=' 'return' = m@
-[Associativity] @m '>>=' (\\x -> k x '>>=' h) = (m '>>=' k) '>>=' h@
-
-Furthermore, the 'Monad' and 'Applicative' operations should relate as follows:
-
-* @'pure' = 'return'@
-* @m1 '<*>' m2 = m1 '>>=' (\\x1 -> m2 '>>=' (\\x2 -> 'return' (x1 x2)))@
-
-The above laws imply:
-
-* @'fmap' f xs = xs '>>=' 'return' . f@
-* @('>>') = ('*>')@
-
-and that 'pure' and ('<*>') satisfy the applicative functor laws.
-
-The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
-defined in the "Prelude" satisfy these laws.
--}
-class Applicative m => Monad m where
- -- | Sequentially compose two actions, passing any value produced
- -- by the first as an argument to the second.
- --
- -- \'@as '>>=' bs@\' can be understood as the @do@ expression
- --
- -- @
- -- do a <- as
- -- bs a
- -- @
- (>>=) :: forall a b. m a -> (a -> m b) -> m b
-
- -- | Sequentially compose two actions, discarding any value produced
- -- by the first, like sequencing operators (such as the semicolon)
- -- in imperative languages.
- --
- -- \'@as '>>' bs@\' can be understood as the @do@ expression
- --
- -- @
- -- do as
- -- bs
- -- @
- (>>) :: forall a b. m a -> m b -> m b
- m >> k = m >>= \_ -> k -- See Note [Recursive bindings for Applicative/Monad]
- {-# INLINE (>>) #-}
-
- -- | Inject a value into the monadic type.
- return :: a -> m a
- return = pure
-
-{- Note [Recursive bindings for Applicative/Monad]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The original Applicative/Monad proposal stated that after
-implementation, the designated implementation of (>>) would become
-
- (>>) :: forall a b. m a -> m b -> m b
- (>>) = (*>)
-
-by default. You might be inclined to change this to reflect the stated
-proposal, but you really shouldn't! Why? Because people tend to define
-such instances the /other/ way around: in particular, it is perfectly
-legitimate to define an instance of Applicative (*>) in terms of (>>),
-which would lead to an infinite loop for the default implementation of
-Monad! And people do this in the wild.
-
-This turned into a nasty bug that was tricky to track down, and rather
-than eliminate it everywhere upstream, it's easier to just retain the
-original default.
-
--}
-
--- | Same as '>>=', but with the arguments interchanged.
-{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
-(=<<) :: Monad m => (a -> m b) -> m a -> m b
-f =<< x = x >>= f
-
--- | Conditional execution of 'Applicative' expressions. For example,
---
--- > when debug (putStrLn "Debugging")
---
--- will output the string @Debugging@ if the Boolean value @debug@
--- is 'True', and otherwise do nothing.
-when :: (Applicative f) => Bool -> f () -> f ()
-{-# INLINABLE when #-}
-{-# SPECIALISE when :: Bool -> IO () -> IO () #-}
-{-# SPECIALISE when :: Bool -> Maybe () -> Maybe () #-}
-when p s = if p then s else pure ()
-
--- | Evaluate each action in the sequence from left to right,
--- and collect the results.
-sequence :: Monad m => [m a] -> m [a]
-{-# INLINE sequence #-}
-sequence = mapM id
--- Note: [sequence and mapM]
-
--- | @'mapM' f@ is equivalent to @'sequence' . 'map' f at .
-mapM :: Monad m => (a -> m b) -> [a] -> m [b]
-{-# INLINE mapM #-}
-mapM f as = foldr k (return []) as
- where
- k a r = do { x <- f a; xs <- r; return (x:xs) }
-
-{-
-Note: [sequence and mapM]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Originally, we defined
-
-mapM f = sequence . map f
-
-This relied on list fusion to produce efficient code for mapM, and led to
-excessive allocation in cryptarithm2. Defining
-
-sequence = mapM id
-
-relies only on inlining a tiny function (id) and beta reduction, which tends to
-be a more reliable aspect of simplification. Indeed, this does not lead to
-similar problems in nofib.
--}
-
--- | Promote a function to a monad.
-liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
-liftM f m1 = do { x1 <- m1; return (f x1) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right. For example,
---
--- > liftM2 (+) [0,1] [0,2] = [0,2,1,3]
--- > liftM2 (+) (Just 1) Nothing = Nothing
---
-liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
-liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
--- Caution: since this may be used for `liftA2`, we can't use the obvious
--- definition of liftM2 = liftA2.
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
-liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
-liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
-liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
-
-{-# INLINABLE liftM #-}
-{-# SPECIALISE liftM :: (a1->r) -> IO a1 -> IO r #-}
-{-# SPECIALISE liftM :: (a1->r) -> Maybe a1 -> Maybe r #-}
-{-# INLINABLE liftM2 #-}
-{-# SPECIALISE liftM2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-}
-{-# SPECIALISE liftM2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-}
-{-# INLINABLE liftM3 #-}
-{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
-{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}
-{-# INLINABLE liftM4 #-}
-{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO r #-}
-{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe r #-}
-{-# INLINABLE liftM5 #-}
-{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO a5 -> IO r #-}
-{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe a5 -> Maybe r #-}
-
-{- | In many situations, the 'liftM' operations can be replaced by uses of
-'ap', which promotes function application.
-
-> return f `ap` x1 `ap` ... `ap` xn
-
-is equivalent to
-
-> liftMn f x1 x2 ... xn
-
--}
-
-ap :: (Monad m) => m (a -> b) -> m a -> m b
-ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
--- Since many Applicative instances define (<*>) = ap, we
--- cannot define ap = (<*>)
-{-# INLINABLE ap #-}
-{-# SPECIALISE ap :: IO (a -> b) -> IO a -> IO b #-}
-{-# SPECIALISE ap :: Maybe (a -> b) -> Maybe a -> Maybe b #-}
-
--- instances for Prelude types
-
--- | @since 2.01
-instance Functor ((->) r) where
- fmap = (.)
-
--- | @since 2.01
-instance Applicative ((->) r) where
- pure = const
- (<*>) f g x = f x (g x)
- liftA2 q f g x = q (f x) (g x)
-
--- | @since 2.01
-instance Monad ((->) r) where
- f >>= k = \ r -> k (f r) r
-
--- | @since 4.15
-instance Functor Solo where
- fmap f (MkSolo a) = MkSolo (f a)
-
- -- Being strict in the `Solo` argument here seems most consistent
- -- with the concept behind `Solo`: always strict in the wrapper and lazy
- -- in the contents.
- x <$ MkSolo _ = MkSolo x
-
--- | @since 2.01
-instance Functor ((,) a) where
- fmap f (x,y) = (x, f y)
-
--- | @since 2.01
-instance Functor Maybe where
- fmap _ Nothing = Nothing
- fmap f (Just a) = Just (f a)
-
--- | @since 2.01
-instance Applicative Maybe where
- pure = Just
-
- Just f <*> m = fmap f m
- Nothing <*> _m = Nothing
-
- liftA2 f (Just x) (Just y) = Just (f x y)
- liftA2 _ _ _ = Nothing
-
- Just _m1 *> m2 = m2
- Nothing *> _m2 = Nothing
-
--- | @since 2.01
-instance Monad Maybe where
- (Just x) >>= k = k x
- Nothing >>= _ = Nothing
-
- (>>) = (*>)
-
--- -----------------------------------------------------------------------------
--- The Alternative class definition
-
-infixl 3 <|>
-
--- | A monoid on applicative functors.
---
--- If defined, 'some' and 'many' should be the least solutions
--- of the equations:
---
--- * @'some' v = (:) 'Prelude.<$>' v '<*>' 'many' v@
---
--- * @'many' v = 'some' v '<|>' 'pure' []@
-class Applicative f => Alternative f where
- -- | The identity of '<|>'
- empty :: f a
- -- | An associative binary operation
- (<|>) :: f a -> f a -> f a
-
- -- | One or more.
- some :: f a -> f [a]
- some v = some_v
- where
- many_v = some_v <|> pure []
- some_v = liftA2 (:) v many_v
-
- -- | Zero or more.
- many :: f a -> f [a]
- many v = many_v
- where
- many_v = some_v <|> pure []
- some_v = liftA2 (:) v many_v
-
-
--- | Picks the leftmost 'Just' value, or, alternatively, 'Nothing'.
---
--- @since 2.01
-instance Alternative Maybe where
- empty = Nothing
- Nothing <|> r = r
- l <|> _ = l
-
--- -----------------------------------------------------------------------------
--- The MonadPlus class definition
-
--- | Monads that also support choice and failure.
-class (Alternative m, Monad m) => MonadPlus m where
- -- | The identity of 'mplus'. It should also satisfy the equations
- --
- -- > mzero >>= f = mzero
- -- > v >> mzero = mzero
- --
- -- The default definition is
- --
- -- @
- -- mzero = 'empty'
- -- @
- mzero :: m a
- mzero = empty
-
- -- | An associative operation. The default definition is
- --
- -- @
- -- mplus = ('<|>')
- -- @
- mplus :: m a -> m a -> m a
- mplus = (<|>)
-
--- | Picks the leftmost 'Just' value, or, alternatively, 'Nothing'.
---
--- @since 2.01
-instance MonadPlus Maybe
-
----------------------------------------------
--- The non-empty list type
-
-infixr 5 :|
-
--- | Non-empty (and non-strict) list type.
---
--- @since 4.9.0.0
-data NonEmpty a = a :| [a]
- deriving ( Eq -- ^ @since 4.9.0.0
- , Ord -- ^ @since 4.9.0.0
- )
-
--- | @since 4.9.0.0
-instance Functor NonEmpty where
- fmap f ~(a :| as) = f a :| fmap f as
- b <$ ~(_ :| as) = b :| (b <$ as)
-
--- | @since 4.9.0.0
-instance Applicative NonEmpty where
- pure a = a :| []
- (<*>) = ap
- liftA2 = liftM2
-
--- | @since 4.9.0.0
-instance Monad NonEmpty where
- ~(a :| as) >>= f = b :| (bs ++ bs')
- where b :| bs = f a
- bs' = as >>= toList . f
- toList ~(c :| cs) = c : cs
-
-----------------------------------------------
--- The list type
-
--- | @since 2.01
-instance Functor [] where
- {-# INLINE fmap #-}
- fmap = map
-
--- See Note: [List comprehensions and inlining]
--- | @since 2.01
-instance Applicative [] where
- {-# INLINE pure #-}
- pure x = [x]
- {-# INLINE (<*>) #-}
- fs <*> xs = [f x | f <- fs, x <- xs]
- {-# INLINE liftA2 #-}
- liftA2 f xs ys = [f x y | x <- xs, y <- ys]
- {-# INLINE (*>) #-}
- xs *> ys = [y | _ <- xs, y <- ys]
-
--- See Note: [List comprehensions and inlining]
--- | @since 2.01
-instance Monad [] where
- {-# INLINE (>>=) #-}
- xs >>= f = [y | x <- xs, y <- f x]
- {-# INLINE (>>) #-}
- (>>) = (*>)
-
--- | Combines lists by concatenation, starting from the empty list.
---
--- @since 2.01
-instance Alternative [] where
- empty = []
- (<|>) = (++)
-
--- | Combines lists by concatenation, starting from the empty list.
---
--- @since 2.01
-instance MonadPlus []
-
-{-
-A few list functions that appear here because they are used here.
-The rest of the prelude list functions are in GHC.List.
--}
-
-----------------------------------------------
--- foldr/build/augment
-----------------------------------------------
-
--- | 'foldr', applied to a binary operator, a starting value (typically
--- the right-identity of the operator), and a list, reduces the list
--- using the binary operator, from right to left:
---
--- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...)
-
-foldr :: (a -> b -> b) -> b -> [a] -> b
--- foldr _ z [] = z
--- foldr f z (x:xs) = f x (foldr f z xs)
-{-# INLINE [0] foldr #-}
--- Inline only in the final stage, after the foldr/cons rule has had a chance
--- Also note that we inline it when it has *two* parameters, which are the
--- ones we are keen about specialising!
-foldr k z = go
- where
- go [] = z
- go (y:ys) = y `k` go ys
-
--- | A list producer that can be fused with 'foldr'.
--- This function is merely
---
--- > build g = g (:) []
---
--- but GHC's simplifier will transform an expression of the form
--- @'foldr' k z ('build' g)@, which may arise after inlining, to @g k z@,
--- which avoids producing an intermediate list.
-
-build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
-{-# INLINE [1] build #-}
- -- The INLINE is important, even though build is tiny,
- -- because it prevents [] getting inlined in the version that
- -- appears in the interface file. If [] *is* inlined, it
- -- won't match with [] appearing in rules in an importing module.
- --
- -- The "1" says to inline in phase 1
-
-build g = g (:) []
-
--- | A list producer that can be fused with 'foldr'.
--- This function is merely
---
--- > augment g xs = g (:) xs
---
--- but GHC's simplifier will transform an expression of the form
--- @'foldr' k z ('augment' g xs)@, which may arise after inlining, to
--- @g k ('foldr' k z xs)@, which avoids producing an intermediate list.
-
-augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
-{-# INLINE [1] augment #-}
-augment g xs = g (:) xs
-
-{-# RULES
-"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) .
- foldr k z (build g) = g k z
-
-"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .
- foldr k z (augment g xs) = g k (foldr k z xs)
-
-"foldr/id" foldr (:) [] = \x -> x
-"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys
- -- Only activate this from phase 1, because that's
- -- when we disable the rule that expands (++) into foldr
-
--- The foldr/cons rule looks nice, but it can give disastrously
--- bloated code when compiling
--- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]
--- i.e. when there are very very long literal lists
--- So I've disabled it for now. We could have special cases
--- for short lists, I suppose.
--- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
-
-"foldr/single" forall k z x. foldr k z [x] = k x z
-"foldr/nil" forall k z. foldr k z [] = z
-
-"foldr/cons/build" forall k z x (g::forall b. (a->b->b) -> b -> b) .
- foldr k z (x:build g) = k x (g k z)
-
-"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
- (h::forall b. (a->b->b) -> b -> b) .
- augment g (build h) = build (\c n -> g c (h c n))
-"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) .
- augment g [] = build g
- #-}
-
--- This rule is true, but not (I think) useful:
--- augment g (augment h t) = augment (\cn -> g c (h c n)) t
-
-----------------------------------------------
--- map
-----------------------------------------------
-
--- | \(\mathcal{O}(n)\). 'map' @f xs@ is the list obtained by applying @f@ to
--- each element of @xs@, i.e.,
---
--- > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn]
--- > map f [x1, x2, ...] == [f x1, f x2, ...]
---
--- >>> map (+1) [1, 2, 3]
--- [2,3,4]
-map :: (a -> b) -> [a] -> [b]
-{-# NOINLINE [0] map #-}
- -- We want the RULEs "map" and "map/coerce" to fire first.
- -- map is recursive, so won't inline anyway,
- -- but saying so is more explicit, and silences warnings
-map _ [] = []
-map f (x:xs) = f x : map f xs
-
--- Note eta expanded
-mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
-{-# INLINE [0] mapFB #-} -- See Note [Inline FB functions] in GHC.List
-mapFB c f = \x ys -> c (f x) ys
-
-{- Note [The rules for map]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The rules for map work like this.
-
-* Up to (but not including) phase 1, we use the "map" rule to
- rewrite all saturated applications of map with its build/fold
- form, hoping for fusion to happen.
-
- In phase 1 and 0, we switch off that rule, inline build, and
- switch on the "mapList" rule, which rewrites the foldr/mapFB
- thing back into plain map.
-
- It's important that these two rules aren't both active at once
- (along with build's unfolding) else we'd get an infinite loop
- in the rules. Hence the activation control below.
-
-* This same pattern is followed by many other functions:
- e.g. append, filter, iterate, repeat, etc. in GHC.List
-
- See also Note [Inline FB functions] in GHC.List
-
-* The "mapFB" rule optimises compositions of map
-
-* The "mapFB/id" rule gets rid of 'map id' calls.
- You might think that (mapFB c id) will turn into c simply
- when mapFB is inlined; but before that happens the "mapList"
- rule turns
- (foldr (mapFB (:) id) [] a
- back into
- map id
- Which is not very clever.
-
-* Any similarity to the Functor laws for [] is expected.
--}
-
-{-# RULES
-"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
-"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f
-"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
-"mapFB/id" forall c. mapFB c (\x -> x) = c
- #-}
-
--- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost
--- Coercions for Haskell", section 6.5:
--- http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf
-
-{-# RULES "map/coerce" [1] map coerce = coerce #-}
--- See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt
-
-----------------------------------------------
--- append
-----------------------------------------------
-
--- | Append two lists, i.e.,
---
--- > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn]
--- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...]
---
--- If the first list is not finite, the result is the first list.
---
--- WARNING: This function takes linear time in the number of elements of the
--- first list.
-
-(++) :: [a] -> [a] -> [a]
-{-# NOINLINE [2] (++) #-}
- -- Give time for the RULEs for (++) to fire in InitialPhase
- -- It's recursive, so won't inline anyway,
- -- but saying so is more explicit
-(++) [] ys = ys
-(++) (x:xs) ys = x : xs ++ ys
-
-{-# RULES
-"++/literal" forall x. (++) (unpackCString# x) = unpackAppendCString# x
-"++/literal_utf8" forall x. (++) (unpackCStringUtf8# x) = unpackAppendCStringUtf8# x #-}
-
-{-# RULES
-"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
- #-}
-
-
-- |'otherwise' is defined as the value 'True'. It helps to make
-- guards more readable. eg.
--
@@ -1489,35 +195,6 @@ The rules for map work like this.
otherwise :: Bool
otherwise = True
-----------------------------------------------
--- Type Char and String
-----------------------------------------------
-
--- | A 'String' is a list of characters. String constants in Haskell are values
--- of type 'String'.
---
--- See "Data.List" for operations on lists.
-type String = [Char]
-
-unsafeChr :: Int -> Char
-unsafeChr (I# i#) = C# (chr# i#)
-
--- | The 'Prelude.fromEnum' method restricted to the type 'Data.Char.Char'.
-ord :: Char -> Int
-ord (C# c#) = I# (ord# c#)
-
--- | This 'String' equality predicate is used when desugaring
--- pattern-matches against strings.
-eqString :: String -> String -> Bool
-eqString [] [] = True
-eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2
-eqString _ _ = False
-
-{-# RULES "eqString" (==) = eqString #-}
--- eqString also has a BuiltInRule in GHC.Core.Opt.ConstantFold:
--- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
-
-
----------------------------------------------
-- 'Int' related definitions
----------------------------------------------
@@ -1536,16 +213,6 @@ minInt = I# (-0x8000000000000000#)
maxInt = I# 0x7FFFFFFFFFFFFFFF#
#endif
-----------------------------------------------
--- The function type
-----------------------------------------------
-
--- | Identity function.
---
--- > id x = x
-id :: a -> a
-id x = x
-
-- Assertion function. This simply ignores its boolean argument.
-- The compiler may rewrite it to @('assertError' line)@.
@@ -1574,112 +241,7 @@ breakpointCond :: Bool -> a -> a
breakpointCond _ r = r
data Opaque = forall a. O a
--- | @const x y@ always evaluates to @x@, ignoring its second argument.
---
--- >>> const 42 "hello"
--- 42
---
--- >>> map (const 42) [0..3]
--- [42,42,42,42]
-const :: a -> b -> a
-const x _ = x
-
--- | Function composition.
-{-# INLINE (.) #-}
--- Make sure it has TWO args only on the left, so that it inlines
--- when applied to two functions, even if there is no final argument
-(.) :: (b -> c) -> (a -> b) -> a -> c
-(.) f g = \x -> f (g x)
-
--- | @'flip' f@ takes its (first) two arguments in the reverse order of @f at .
---
--- >>> flip (++) "hello" "world"
--- "worldhello"
-flip :: (a -> b -> c) -> b -> a -> c
-flip f x y = f y x
-
--- Note: Before base-4.19, ($) was not representation polymorphic
--- in both type parameters but only in the return type.
--- The generalization forced a change to the implementation,
--- changing its laziness, affecting expressions like (($) undefined): before
--- base-4.19 the expression (($) undefined) `seq` () was equivalent to
--- (\x -> undefined x) `seq` () and thus would just evaluate to (), but now
--- it is equivalent to undefined `seq` () which diverges.
-
-{- | @($)@ is the __function application__ operator.
-
-Applying @($)@ to a function @f@ and an argument @x@ gives the same result as applying @f@ to @x@ directly. The definition is akin to this:
-
-@
-($) :: (a -> b) -> a -> b
-($) f x = f x
-@
-
-On the face of it, this may appear pointless! But it's actually one of the most useful and important operators in Haskell.
-
-The order of operations is very different between @($)@ and normal function application. Normal function application has precedence 10 - higher than any operator - and associates to the left. So these two definitions are equivalent:
-
-@
-expr = min 5 1 + 5
-expr = ((min 5) 1) + 5
-@
-
-@($)@ has precedence 0 (the lowest) and associates to the right, so these are equivalent:
-
-@
-expr = min 5 $ 1 + 5
-expr = (min 5) (1 + 5)
-@
-
-=== Uses
-A common use cases of @($)@ is to avoid parentheses in complex expressions.
-
-For example, instead of using nested parentheses in the following
- Haskell function:
-
-@
--- | Sum numbers in a string: strSum "100 5 -7" == 98
-strSum :: 'String' -> 'Int'
-strSum s = 'sum' ('Data.Maybe.mapMaybe' 'Text.Read.readMaybe' ('words' s))
-@
-
-we can deploy the function application operator:
-
-@
--- | Sum numbers in a string: strSum "100 5 -7" == 98
-strSum :: 'String' -> 'Int'
-strSum s = 'sum' '$' 'Data.Maybe.mapMaybe' 'Text.Read.readMaybe' '$' 'words' s
-@
-
-@($)@ is also used as a section (a partially applied operator), in order to indicate that we wish to apply some yet-unspecified function to a given value. For example, to apply the argument @5@ to a list of functions:
-
-@
-applyFive :: [Int]
-applyFive = map ($ 5) [(+1), (2^)]
->>> [6, 32]
-@
-
-=== Technical Remark (Representation Polymorphism)
-
-@($)@ is fully representation-polymorphic. This allows it to also be used with arguments of unlifted and even unboxed kinds, such as unboxed integers:
-
-@
-fastMod :: Int -> Int -> Int
-fastMod (I# x) (I# m) = I# $ remInt# x m
-@
--}
-{-# INLINE ($) #-}
-($) :: forall repa repb (a :: TYPE repa) (b :: TYPE repb). (a -> b) -> a -> b
-($) f = f
-
--- | Strict (call-by-value) application operator. It takes a function and an
--- argument, evaluates the argument to weak head normal form (WHNF), then calls
--- the function with that value.
-
-($!) :: forall r a (b :: TYPE r). (a -> b) -> a -> b
-{-# INLINE ($!) #-}
-f $! x = let !vx = x in f vx -- see #2273
-- | @'until' p f@ yields the result of applying @f@ until @p@ holds.
until :: (a -> Bool) -> (a -> a) -> a -> a
@@ -1688,70 +250,6 @@ until p f = go
go x | p x = x
| otherwise = go (f x)
--- | 'asTypeOf' is a type-restricted version of 'const'. It is usually
--- used as an infix operator, and its typing forces its first argument
--- (which is usually overloaded) to have the same type as the second.
-asTypeOf :: a -> a -> a
-asTypeOf = const
-
-----------------------------------------------
--- Functor/Applicative/Monad instances for IO
-----------------------------------------------
-
--- | @since 2.01
-instance Functor IO where
- fmap f x = x >>= (pure . f)
-
--- | @since 2.01
-instance Applicative IO where
- {-# INLINE pure #-}
- {-# INLINE (*>) #-}
- {-# INLINE liftA2 #-}
- pure = returnIO
- (*>) = thenIO
- (<*>) = ap
- liftA2 = liftM2
-
--- | @since 2.01
-instance Monad IO where
- {-# INLINE (>>) #-}
- {-# INLINE (>>=) #-}
- (>>) = (*>)
- (>>=) = bindIO
-
--- | Takes the first non-throwing 'IO' action\'s result.
--- 'empty' throws an exception.
---
--- @since 4.9.0.0
-instance Alternative IO where
- empty = failIO "mzero"
- (<|>) = mplusIO
-
--- | Takes the first non-throwing 'IO' action\'s result.
--- 'mzero' throws an exception.
---
--- @since 4.9.0.0
-instance MonadPlus IO
-
-returnIO :: a -> IO a
-returnIO x = IO (\ s -> (# s, x #))
-
-bindIO :: IO a -> (a -> IO b) -> IO b
-bindIO (IO m) k = IO (\ s -> case m s of (# new_s, a #) -> unIO (k a) new_s)
-
-thenIO :: IO a -> IO b -> IO b
-thenIO (IO m) k = IO (\ s -> case m s of (# new_s, _ #) -> unIO k new_s)
-
--- Note that it is import that we do not SOURCE import this as
--- its demand signature encodes knowledge of its bottoming
--- behavior, which can expose useful simplifications. See
--- #16588.
-failIO :: String -> IO a
-failIO s = IO (raiseIO# (mkUserError s))
-
-unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
-unIO (IO a) = a
-
{- |
Returns the tag of a constructor application; this function is used
by the deriving code for Eq, Ord and Enum.
@@ -1918,21 +416,3 @@ a `iShiftRA#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = negateInt# (a <# 0#)
iShiftRL# :: Int# -> Int# -> Int#
a `iShiftRL#` b = (a `uncheckedIShiftRL#` b) `andI#` shift_mask WORD_SIZE_IN_BITS# b
--- Rules for C strings (the functions themselves are now in GHC.CString)
-{-# RULES
-"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a)
-"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a
-"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n
-"unpack-append-nil" forall a . unpackAppendCString# a [] = unpackCString# a
-
-"unpack-utf8" [~1] forall a . unpackCStringUtf8# a = build (unpackFoldrCStringUtf8# a)
-"unpack-list-utf8" [1] forall a . unpackFoldrCStringUtf8# a (:) [] = unpackCStringUtf8# a
-"unpack-append-utf8" forall a n . unpackFoldrCStringUtf8# a (:) n = unpackAppendCStringUtf8# a n
-"unpack-append-nil-utf8" forall a . unpackAppendCStringUtf8# a [] = unpackCStringUtf8# a
-
--- There's a built-in rule (in GHC.Core.Op.ConstantFold) for
--- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
-
--- See also the Note [String literals in GHC] in CString.hs
-
- #-}
=====================================
libraries/base/GHC/Base/FunOps.hs
=====================================
@@ -0,0 +1,140 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes #-}
+
+module GHC.Base.FunOps
+ ( id
+ , const
+ , (.)
+ , flip
+ , ($)
+ , ($!)
+ , asTypeOf
+ ) where
+
+import GHC.Types
+
+infixr 9 .
+infixr 0 $, $!
+
+-- | Identity function.
+--
+-- > id x = x
+id :: a -> a
+id x = x
+
+-- | @const x y@ always evaluates to @x@, ignoring its second argument.
+--
+-- >>> const 42 "hello"
+-- 42
+--
+-- >>> map (const 42) [0..3]
+-- [42,42,42,42]
+const :: a -> b -> a
+const x _ = x
+
+-- | Function composition.
+{-# INLINE (.) #-}
+-- Make sure it has TWO args only on the left, so that it inlines
+-- when applied to two functions, even if there is no final argument
+(.) :: (b -> c) -> (a -> b) -> a -> c
+(.) f g = \x -> f (g x)
+
+-- | @'flip' f@ takes its (first) two arguments in the reverse order of @f at .
+--
+-- >>> flip (++) "hello" "world"
+-- "worldhello"
+flip :: (a -> b -> c) -> b -> a -> c
+flip f x y = f y x
+
+-- Note: Before base-4.19, ($) was not representation polymorphic
+-- in both type parameters but only in the return type.
+-- The generalization forced a change to the implementation,
+-- changing its laziness, affecting expressions like (($) undefined): before
+-- base-4.19 the expression (($) undefined) `seq` () was equivalent to
+-- (\x -> undefined x) `seq` () and thus would just evaluate to (), but now
+-- it is equivalent to undefined `seq` () which diverges.
+
+{- | @($)@ is the __function application__ operator.
+
+Applying @($)@ to a function @f@ and an argument @x@ gives the same result as applying @f@ to @x@ directly. The definition is akin to this:
+
+@
+($) :: (a -> b) -> a -> b
+($) f x = f x
+@
+
+On the face of it, this may appear pointless! But it's actually one of the most useful and important operators in Haskell.
+
+The order of operations is very different between @($)@ and normal function application. Normal function application has precedence 10 - higher than any operator - and associates to the left. So these two definitions are equivalent:
+
+@
+expr = min 5 1 + 5
+expr = ((min 5) 1) + 5
+@
+
+@($)@ has precedence 0 (the lowest) and associates to the right, so these are equivalent:
+
+@
+expr = min 5 $ 1 + 5
+expr = (min 5) (1 + 5)
+@
+
+=== Uses
+
+A common use cases of @($)@ is to avoid parentheses in complex expressions.
+
+For example, instead of using nested parentheses in the following
+ Haskell function:
+
+@
+-- | Sum numbers in a string: strSum "100 5 -7" == 98
+strSum :: 'String' -> 'Int'
+strSum s = 'sum' ('Data.Maybe.mapMaybe' 'Text.Read.readMaybe' ('words' s))
+@
+
+we can deploy the function application operator:
+
+@
+-- | Sum numbers in a string: strSum "100 5 -7" == 98
+strSum :: 'String' -> 'Int'
+strSum s = 'sum' '$' 'Data.Maybe.mapMaybe' 'Text.Read.readMaybe' '$' 'words' s
+@
+
+@($)@ is also used as a section (a partially applied operator), in order to indicate that we wish to apply some yet-unspecified function to a given value. For example, to apply the argument @5@ to a list of functions:
+
+@
+applyFive :: [Int]
+applyFive = map ($ 5) [(+1), (2^)]
+>>> [6, 32]
+@
+
+=== Technical Remark (Representation Polymorphism)
+
+@($)@ is fully representation-polymorphic. This allows it to also be used with arguments of unlifted and even unboxed kinds, such as unboxed integers:
+
+@
+fastMod :: Int -> Int -> Int
+fastMod (I# x) (I# m) = I# $ remInt# x m
+@
+-}
+{-# INLINE ($) #-}
+($) :: forall repa repb (a :: TYPE repa) (b :: TYPE repb). (a -> b) -> a -> b
+($) f = f
+
+-- | Strict (call-by-value) application operator. It takes a function and an
+-- argument, evaluates the argument to weak head normal form (WHNF), then calls
+-- the function with that value.
+
+($!) :: forall r a (b :: TYPE r). (a -> b) -> a -> b
+{-# INLINE ($!) #-}
+f $! x = let !vx = x in f vx -- see #2273
+
+-- | 'asTypeOf' is a type-restricted version of 'const'. It is usually
+-- used as an infix operator, and its typing forces its first argument
+-- (which is usually overloaded) to have the same type as the second.
+asTypeOf :: a -> a -> a
+asTypeOf = const
+
=====================================
libraries/base/GHC/Base/Functor.hs
=====================================
@@ -0,0 +1,883 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE RankNTypes #-}
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Base.Functor
+-- Copyright : (c) The University of Glasgow, 1992-2002
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc at haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC extensions)
+--
+-- The functor class hierarchy.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Base.Functor
+ ( Functor(..)
+ , Applicative(..)
+ , Monad(..)
+ , liftA
+ , liftA3
+ , join
+ , when
+ , sequence
+ , mapM
+ , liftM
+ , liftM2
+ , liftM3
+ , liftM4
+ , liftM5
+ , ap
+ , (<**>)
+ , (=<<)
+ -- * Alternative
+ , Alternative(..)
+ , MonadPlus(..)
+ -- * 'IO' helpers
+ , returnIO
+ , bindIO
+ , thenIO
+ , failIO
+ , unIO
+ ) where
+
+import GHC.Types (Bool, IO(..))
+import GHC.Prim (State#, RealWorld, raiseIO#)
+import GHC.Tuple (Solo(..))
+
+import GHC.Base.FunOps (const, id, (.))
+import GHC.Base.List
+import GHC.Base.NonEmpty (NonEmpty(..))
+import GHC.Base.Semigroup (Monoid(mempty), Semigroup((<>)))
+import GHC.Base.String (String)
+import GHC.Maybe (Maybe(..))
+
+import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO)
+
+default () -- Double isn't available yet
+
+infixl 4 <$
+infixl 1 >>, >>=
+infixr 1 =<<
+infixl 4 <*>, <*, *>, <**>
+infixl 3 <|>
+
+{- | A type @f@ is a Functor if it provides a function @fmap@ which, given any types @a@ and @b@
+lets you apply any function from @(a -> b)@ to turn an @f a@ into an @f b@, preserving the
+structure of @f at . Furthermore @f@ needs to adhere to the following:
+
+[Identity] @'fmap' 'id' == 'id'@
+[Composition] @'fmap' (f . g) == 'fmap' f . 'fmap' g@
+
+Note, that the second law follows from the free theorem of the type 'fmap' and
+the first law, so you need only check that the former condition holds.
+See <https://www.schoolofhaskell.com/user/edwardk/snippets/fmap> or
+<https://github.com/quchen/articles/blob/master/second_functor_law.md>
+for an explanation.
+-}
+
+class Functor f where
+ -- | 'fmap' is used to apply a function of type @(a -> b)@ to a value of type @f a@,
+ -- where f is a functor, to produce a value of type @f b at .
+ -- Note that for any type constructor with more than one parameter (e.g., `Either`),
+ -- only the last type parameter can be modified with `fmap` (e.g., `b` in `Either a b`).
+ --
+ -- Some type constructors with two parameters or more have a @'Data.Bifunctor'@ instance that allows
+ -- both the last and the penultimate parameters to be mapped over.
+ --
+ -- ==== __Examples__
+ --
+ -- Convert from a @'Data.Maybe.Maybe' Int@ to a @Maybe String@
+ -- using 'Prelude.show':
+ --
+ -- >>> fmap show Nothing
+ -- Nothing
+ -- >>> fmap show (Just 3)
+ -- Just "3"
+ --
+ -- Convert from an @'Data.Either.Either' Int Int@ to an
+ -- @Either Int String@ using 'Prelude.show':
+ --
+ -- >>> fmap show (Left 17)
+ -- Left 17
+ -- >>> fmap show (Right 17)
+ -- Right "17"
+ --
+ -- Double each element of a list:
+ --
+ -- >>> fmap (*2) [1,2,3]
+ -- [2,4,6]
+ --
+ -- Apply 'Prelude.even' to the second element of a pair:
+ --
+ -- >>> fmap even (2,2)
+ -- (2,True)
+ --
+ -- It may seem surprising that the function is only applied to the last element of the tuple
+ -- compared to the list example above which applies it to every element in the list.
+ -- To understand, remember that tuples are type constructors with multiple type parameters:
+ -- a tuple of 3 elements @(a,b,c)@ can also be written @(,,) a b c@ and its @Functor@ instance
+ -- is defined for @Functor ((,,) a b)@ (i.e., only the third parameter is free to be mapped over
+ -- with @fmap@).
+ --
+ -- It explains why @fmap@ can be used with tuples containing values of different types as in the
+ -- following example:
+ --
+ -- >>> fmap even ("hello", 1.0, 4)
+ -- ("hello",1.0,True)
+
+ fmap :: (a -> b) -> f a -> f b
+
+ -- | Replace all locations in the input with the same value.
+ -- The default definition is @'fmap' . 'const'@, but this may be
+ -- overridden with a more efficient version.
+ --
+ -- ==== __Examples__
+ --
+ -- Perform a computation with 'Maybe' and replace the result with a
+ -- constant value if it is 'Just':
+ --
+ -- >>> 'a' <$ Just 2
+ -- Just 'a'
+ -- >>> 'a' <$ Nothing
+ -- Nothing
+ (<$) :: a -> f b -> f a
+ (<$) = fmap . const
+
+-- | A functor with application, providing operations to
+--
+-- * embed pure expressions ('pure'), and
+--
+-- * sequence computations and combine their results ('<*>' and 'liftA2').
+--
+-- A minimal complete definition must include implementations of 'pure'
+-- and of either '<*>' or 'liftA2'. If it defines both, then they must behave
+-- the same as their default definitions:
+--
+-- @('<*>') = 'liftA2' 'id'@
+--
+-- @'liftA2' f x y = f 'Prelude.<$>' x '<*>' y@
+--
+-- Further, any definition must satisfy the following:
+--
+-- [Identity]
+--
+-- @'pure' 'id' '<*>' v = v@
+--
+-- [Composition]
+--
+-- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
+--
+-- [Homomorphism]
+--
+-- @'pure' f '<*>' 'pure' x = 'pure' (f x)@
+--
+-- [Interchange]
+--
+-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
+--
+--
+-- The other methods have the following default definitions, which may
+-- be overridden with equivalent specialized implementations:
+--
+-- * @u '*>' v = ('id' '<$' u) '<*>' v@
+--
+-- * @u '<*' v = 'liftA2' 'const' u v@
+--
+-- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
+--
+-- * @'fmap' f x = 'pure' f '<*>' x@
+--
+--
+-- It may be useful to note that supposing
+--
+-- @forall x y. p (q x y) = f x . g y@
+--
+-- it follows from the above that
+--
+-- @'liftA2' p ('liftA2' q u v) = 'liftA2' f u . 'liftA2' g v@
+--
+--
+-- If @f@ is also a 'Monad', it should satisfy
+--
+-- * @'pure' = 'return'@
+--
+-- * @m1 '<*>' m2 = m1 '>>=' (\\x1 -> m2 '>>=' (\\x2 -> 'return' (x1 x2)))@
+--
+-- * @('*>') = ('>>')@
+--
+-- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
+
+class Functor f => Applicative f where
+ {-# MINIMAL pure, ((<*>) | liftA2) #-}
+ -- | Lift a value.
+ pure :: a -> f a
+
+ -- | Sequential application.
+ --
+ -- A few functors support an implementation of '<*>' that is more
+ -- efficient than the default one.
+ --
+ -- ==== __Example__
+ -- Used in combination with @('<$>')@, @('<*>')@ can be used to build a record.
+ --
+ -- >>> data MyState = MyState {arg1 :: Foo, arg2 :: Bar, arg3 :: Baz}
+ --
+ -- >>> produceFoo :: Applicative f => f Foo
+ --
+ -- >>> produceBar :: Applicative f => f Bar
+ -- >>> produceBaz :: Applicative f => f Baz
+ --
+ -- >>> mkState :: Applicative f => f MyState
+ -- >>> mkState = MyState <$> produceFoo <*> produceBar <*> produceBaz
+ (<*>) :: f (a -> b) -> f a -> f b
+ (<*>) = liftA2 id
+
+ -- | Lift a binary function to actions.
+ --
+ -- Some functors support an implementation of 'liftA2' that is more
+ -- efficient than the default one. In particular, if 'fmap' is an
+ -- expensive operation, it is likely better to use 'liftA2' than to
+ -- 'fmap' over the structure and then use '<*>'.
+ --
+ -- This became a typeclass method in 4.10.0.0. Prior to that, it was
+ -- a function defined in terms of '<*>' and 'fmap'.
+ --
+ -- ==== __Example__
+ -- >>> liftA2 (,) (Just 3) (Just 5)
+ -- Just (3,5)
+
+ liftA2 :: (a -> b -> c) -> f a -> f b -> f c
+ liftA2 f x = (<*>) (fmap f x)
+
+ -- | Sequence actions, discarding the value of the first argument.
+ --
+ -- ==== __Examples__
+ -- If used in conjunction with the Applicative instance for 'Maybe',
+ -- you can chain Maybe computations, with a possible "early return"
+ -- in case of 'Nothing'.
+ --
+ -- >>> Just 2 *> Just 3
+ -- Just 3
+ --
+ -- >>> Nothing *> Just 3
+ -- Nothing
+ --
+ -- Of course a more interesting use case would be to have effectful
+ -- computations instead of just returning pure values.
+ --
+ -- >>> import Data.Char
+ -- >>> import Text.ParserCombinators.ReadP
+ -- >>> let p = string "my name is " *> munch1 isAlpha <* eof
+ -- >>> readP_to_S p "my name is Simon"
+ -- [("Simon","")]
+
+ (*>) :: f a -> f b -> f b
+ a1 *> a2 = (id <$ a1) <*> a2
+
+ -- This is essentially the same as liftA2 (flip const), but if the
+ -- Functor instance has an optimized (<$), it may be better to use
+ -- that instead. Before liftA2 became a method, this definition
+ -- was strictly better, but now it depends on the functor. For a
+ -- functor supporting a sharing-enhancing (<$), this definition
+ -- may reduce allocation by preventing a1 from ever being fully
+ -- realized. In an implementation with a boring (<$) but an optimizing
+ -- liftA2, it would likely be better to define (*>) using liftA2.
+
+ -- | Sequence actions, discarding the value of the second argument.
+ --
+ (<*) :: f a -> f b -> f a
+ (<*) = liftA2 const
+
+{- | The 'Monad' class defines the basic operations over a /monad/,
+a concept from a branch of mathematics known as /category theory/.
+From the perspective of a Haskell programmer, however, it is best to
+think of a monad as an /abstract datatype/ of actions.
+Haskell's @do@ expressions provide a convenient syntax for writing
+monadic expressions.
+
+Instances of 'Monad' should satisfy the following:
+
+[Left identity] @'return' a '>>=' k = k a@
+[Right identity] @m '>>=' 'return' = m@
+[Associativity] @m '>>=' (\\x -> k x '>>=' h) = (m '>>=' k) '>>=' h@
+
+Furthermore, the 'Monad' and 'Applicative' operations should relate as follows:
+
+* @'pure' = 'return'@
+* @m1 '<*>' m2 = m1 '>>=' (\\x1 -> m2 '>>=' (\\x2 -> 'return' (x1 x2)))@
+
+The above laws imply:
+
+* @'fmap' f xs = xs '>>=' 'return' . f@
+* @('>>') = ('*>')@
+
+and that 'pure' and ('<*>') satisfy the applicative functor laws.
+
+The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
+defined in the "Prelude" satisfy these laws.
+-}
+class Applicative m => Monad m where
+ -- | Sequentially compose two actions, passing any value produced
+ -- by the first as an argument to the second.
+ --
+ -- \'@as '>>=' bs@\' can be understood as the @do@ expression
+ --
+ -- @
+ -- do a <- as
+ -- bs a
+ -- @
+ (>>=) :: forall a b. m a -> (a -> m b) -> m b
+
+ -- | Sequentially compose two actions, discarding any value produced
+ -- by the first, like sequencing operators (such as the semicolon)
+ -- in imperative languages.
+ --
+ -- \'@as '>>' bs@\' can be understood as the @do@ expression
+ --
+ -- @
+ -- do as
+ -- bs
+ -- @
+ (>>) :: forall a b. m a -> m b -> m b
+ m >> k = m >>= \_ -> k -- See Note [Recursive bindings for Applicative/Monad]
+ {-# INLINE (>>) #-}
+
+ -- | Inject a value into the monadic type.
+ return :: a -> m a
+ return = pure
+
+-- | @since 4.15
+instance Applicative Solo where
+ pure = MkSolo
+
+ -- Note: we really want to match strictly here. This lets us write,
+ -- for example,
+ --
+ -- forceSpine :: Foldable f => f a -> ()
+ -- forceSpine xs
+ -- | MkSolo r <- traverse_ MkSolo xs
+ -- = r
+ MkSolo f <*> MkSolo x = MkSolo (f x)
+ liftA2 f (MkSolo x) (MkSolo y) = MkSolo (f x y)
+
+-- | For tuples, the 'Monoid' constraint on @a@ determines
+-- how the first values merge.
+-- For example, 'String's concatenate:
+--
+-- > ("hello ", (+15)) <*> ("world!", 2002)
+-- > ("hello world!",2017)
+--
+-- @since 2.01
+instance Monoid a => Applicative ((,) a) where
+ pure x = (mempty, x)
+ (u, f) <*> (v, x) = (u <> v, f x)
+ liftA2 f (u, x) (v, y) = (u <> v, f x y)
+
+-- | @since 4.15
+instance Monad Solo where
+ MkSolo x >>= f = f x
+
+-- | @since 4.9.0.0
+instance Monoid a => Monad ((,) a) where
+ (u, a) >>= k = case k a of (v, b) -> (u <> v, b)
+
+-- | @since 4.14.0.0
+instance Functor ((,,) a b) where
+ fmap f (a, b, c) = (a, b, f c)
+
+-- | @since 4.14.0.0
+instance (Monoid a, Monoid b) => Applicative ((,,) a b) where
+ pure x = (mempty, mempty, x)
+ (a, b, f) <*> (a', b', x) = (a <> a', b <> b', f x)
+
+-- | @since 4.14.0.0
+instance (Monoid a, Monoid b) => Monad ((,,) a b) where
+ (u, v, a) >>= k = case k a of (u', v', b) -> (u <> u', v <> v', b)
+
+-- | @since 4.14.0.0
+instance Functor ((,,,) a b c) where
+ fmap f (a, b, c, d) = (a, b, c, f d)
+
+-- | @since 4.14.0.0
+instance (Monoid a, Monoid b, Monoid c) => Applicative ((,,,) a b c) where
+ pure x = (mempty, mempty, mempty, x)
+ (a, b, c, f) <*> (a', b', c', x) = (a <> a', b <> b', c <> c', f x)
+
+-- | @since 4.14.0.0
+instance (Monoid a, Monoid b, Monoid c) => Monad ((,,,) a b c) where
+ (u, v, w, a) >>= k = case k a of (u', v', w', b) -> (u <> u', v <> v', w <> w', b)
+
+-- | @since 4.18.0.0
+instance Functor ((,,,,) a b c d) where
+ fmap f (a, b, c, d, e) = (a, b, c, d, f e)
+
+-- | @since 4.18.0.0
+instance Functor ((,,,,,) a b c d e) where
+ fmap fun (a, b, c, d, e, f) = (a, b, c, d, e, fun f)
+
+-- | @since 4.18.0.0
+instance Functor ((,,,,,,) a b c d e f) where
+ fmap fun (a, b, c, d, e, f, g) = (a, b, c, d, e, f, fun g)
+
+-- | A variant of '<*>' with the arguments reversed.
+--
+(<**>) :: Applicative f => f a -> f (a -> b) -> f b
+(<**>) = liftA2 (\a f -> f a)
+-- Don't use $ here, see the note at the top of the page
+
+-- | Lift a function to actions.
+-- Equivalent to Functor's `fmap` but implemented using only `Applicative`'s methods:
+-- @'liftA' f a = 'pure' f '<*>' a@
+--
+-- As such this function may be used to implement a `Functor` instance from an `Applicative` one.
+--
+-- ==== __Examples__
+-- Using the Applicative instance for Lists:
+--
+-- >>> liftA (+1) [1, 2]
+-- [2,3]
+--
+-- Or the Applicative instance for 'Maybe'
+--
+-- >>> liftA (+1) (Just 3)
+-- Just 4
+
+liftA :: Applicative f => (a -> b) -> f a -> f b
+liftA f a = pure f <*> a
+-- Caution: since this may be used for `fmap`, we can't use the obvious
+-- definition of liftA = fmap.
+
+-- | Lift a ternary function to actions.
+
+liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
+liftA3 f a b c = liftA2 f a b <*> c
+
+
+{-# INLINABLE liftA #-}
+{-# SPECIALISE liftA :: (a1->r) -> IO a1 -> IO r #-}
+{-# SPECIALISE liftA :: (a1->r) -> Maybe a1 -> Maybe r #-}
+{-# INLINABLE liftA3 #-}
+{-# SPECIALISE liftA3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
+{-# SPECIALISE liftA3 :: (a1->a2->a3->r) ->
+ Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}
+
+-- | The 'join' function is the conventional monad join operator. It
+-- is used to remove one level of monadic structure, projecting its
+-- bound argument into the outer level.
+--
+--
+-- \'@'join' bss@\' can be understood as the @do@ expression
+--
+-- @
+-- do bs <- bss
+-- bs
+-- @
+--
+-- ==== __Examples__
+--
+-- A common use of 'join' is to run an 'IO' computation returned from
+-- an 'GHC.Conc.STM' transaction, since 'GHC.Conc.STM' transactions
+-- can't perform 'IO' directly. Recall that
+--
+-- @
+-- 'GHC.Conc.atomically' :: STM a -> IO a
+-- @
+--
+-- is used to run 'GHC.Conc.STM' transactions atomically. So, by
+-- specializing the types of 'GHC.Conc.atomically' and 'join' to
+--
+-- @
+-- 'GHC.Conc.atomically' :: STM (IO b) -> IO (IO b)
+-- 'join' :: IO (IO b) -> IO b
+-- @
+--
+-- we can compose them as
+--
+-- @
+-- 'join' . 'GHC.Conc.atomically' :: STM (IO b) -> IO b
+-- @
+--
+-- to run an 'GHC.Conc.STM' transaction and the 'IO' action it
+-- returns.
+join :: (Monad m) => m (m a) -> m a
+join x = x >>= id
+
+
+{- Note [Recursive bindings for Applicative/Monad]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The original Applicative/Monad proposal stated that after
+implementation, the designated implementation of (>>) would become
+
+ (>>) :: forall a b. m a -> m b -> m b
+ (>>) = (*>)
+
+by default. You might be inclined to change this to reflect the stated
+proposal, but you really shouldn't! Why? Because people tend to define
+such instances the /other/ way around: in particular, it is perfectly
+legitimate to define an instance of Applicative (*>) in terms of (>>),
+which would lead to an infinite loop for the default implementation of
+Monad! And people do this in the wild.
+
+This turned into a nasty bug that was tricky to track down, and rather
+than eliminate it everywhere upstream, it's easier to just retain the
+original default.
+
+-}
+
+-- | Same as '>>=', but with the arguments interchanged.
+{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
+(=<<) :: Monad m => (a -> m b) -> m a -> m b
+f =<< x = x >>= f
+
+-- | Conditional execution of 'Applicative' expressions. For example,
+--
+-- > when debug (putStrLn "Debugging")
+--
+-- will output the string @Debugging@ if the Boolean value @debug@
+-- is 'True', and otherwise do nothing.
+when :: (Applicative f) => Bool -> f () -> f ()
+{-# INLINABLE when #-}
+{-# SPECIALISE when :: Bool -> IO () -> IO () #-}
+{-# SPECIALISE when :: Bool -> Maybe () -> Maybe () #-}
+when p s = if p then s else pure ()
+
+-- | Evaluate each action in the sequence from left to right,
+-- and collect the results.
+sequence :: Monad m => [m a] -> m [a]
+{-# INLINE sequence #-}
+sequence = mapM id
+-- Note: [sequence and mapM]
+
+-- | @'mapM' f@ is equivalent to @'sequence' . 'map' f at .
+mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+{-# INLINE mapM #-}
+mapM f as = foldr k (return []) as
+ where
+ k a r = do { x <- f a; xs <- r; return (x:xs) }
+
+{-
+Note: [sequence and mapM]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Originally, we defined
+
+mapM f = sequence . map f
+
+This relied on list fusion to produce efficient code for mapM, and led to
+excessive allocation in cryptarithm2. Defining
+
+sequence = mapM id
+
+relies only on inlining a tiny function (id) and beta reduction, which tends to
+be a more reliable aspect of simplification. Indeed, this does not lead to
+similar problems in nofib.
+-}
+
+-- | Promote a function to a monad.
+liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
+liftM f m1 = do { x1 <- m1; return (f x1) }
+
+-- | Promote a function to a monad, scanning the monadic arguments from
+-- left to right. For example,
+--
+-- > liftM2 (+) [0,1] [0,2] = [0,2,1,3]
+-- > liftM2 (+) (Just 1) Nothing = Nothing
+--
+liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
+liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
+-- Caution: since this may be used for `liftA2`, we can't use the obvious
+-- definition of liftM2 = liftA2.
+
+-- | Promote a function to a monad, scanning the monadic arguments from
+-- left to right (cf. 'liftM2').
+liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
+liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
+
+-- | Promote a function to a monad, scanning the monadic arguments from
+-- left to right (cf. 'liftM2').
+liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
+liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
+
+-- | Promote a function to a monad, scanning the monadic arguments from
+-- left to right (cf. 'liftM2').
+liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
+liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
+
+{-# INLINABLE liftM #-}
+{-# SPECIALISE liftM :: (a1->r) -> IO a1 -> IO r #-}
+{-# SPECIALISE liftM :: (a1->r) -> Maybe a1 -> Maybe r #-}
+{-# INLINABLE liftM2 #-}
+{-# SPECIALISE liftM2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-}
+{-# SPECIALISE liftM2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-}
+{-# INLINABLE liftM3 #-}
+{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
+{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}
+{-# INLINABLE liftM4 #-}
+{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO r #-}
+{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe r #-}
+{-# INLINABLE liftM5 #-}
+{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO a5 -> IO r #-}
+{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe a5 -> Maybe r #-}
+
+{- | In many situations, the 'liftM' operations can be replaced by uses of
+'ap', which promotes function application.
+
+> return f `ap` x1 `ap` ... `ap` xn
+
+is equivalent to
+
+> liftMn f x1 x2 ... xn
+
+-}
+
+ap :: (Monad m) => m (a -> b) -> m a -> m b
+ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
+-- Since many Applicative instances define (<*>) = ap, we
+-- cannot define ap = (<*>)
+{-# INLINABLE ap #-}
+{-# SPECIALISE ap :: IO (a -> b) -> IO a -> IO b #-}
+{-# SPECIALISE ap :: Maybe (a -> b) -> Maybe a -> Maybe b #-}
+
+-- instances for Prelude types
+
+-- | @since 2.01
+instance Functor ((->) r) where
+ fmap = (.)
+
+-- | @since 2.01
+instance Applicative ((->) r) where
+ pure = const
+ (<*>) f g x = f x (g x)
+ liftA2 q f g x = q (f x) (g x)
+
+-- | @since 2.01
+instance Monad ((->) r) where
+ f >>= k = \ r -> k (f r) r
+
+-- | @since 4.15
+instance Functor Solo where
+ fmap f (MkSolo a) = MkSolo (f a)
+
+ -- Being strict in the `Solo` argument here seems most consistent
+ -- with the concept behind `Solo`: always strict in the wrapper and lazy
+ -- in the contents.
+ x <$ MkSolo _ = MkSolo x
+
+-- | @since 2.01
+instance Functor ((,) a) where
+ fmap f (x,y) = (x, f y)
+
+-- | @since 2.01
+instance Functor Maybe where
+ fmap _ Nothing = Nothing
+ fmap f (Just a) = Just (f a)
+
+-- | @since 2.01
+instance Applicative Maybe where
+ pure = Just
+
+ Just f <*> m = fmap f m
+ Nothing <*> _m = Nothing
+
+ liftA2 f (Just x) (Just y) = Just (f x y)
+ liftA2 _ _ _ = Nothing
+
+ Just _m1 *> m2 = m2
+ Nothing *> _m2 = Nothing
+
+-- | @since 2.01
+instance Monad Maybe where
+ (Just x) >>= k = k x
+ Nothing >>= _ = Nothing
+
+ (>>) = (*>)
+
+-- | @since 2.01
+instance Functor [] where
+ {-# INLINE fmap #-}
+ fmap = map
+
+-- See Note: [List comprehensions and inlining]
+-- | @since 2.01
+instance Applicative [] where
+ {-# INLINE pure #-}
+ pure x = [x]
+ {-# INLINE (<*>) #-}
+ fs <*> xs = [f x | f <- fs, x <- xs]
+ {-# INLINE liftA2 #-}
+ liftA2 f xs ys = [f x y | x <- xs, y <- ys]
+ {-# INLINE (*>) #-}
+ xs *> ys = [y | _ <- xs, y <- ys]
+
+-- See Note: [List comprehensions and inlining]
+-- | @since 2.01
+instance Monad [] where
+ {-# INLINE (>>=) #-}
+ xs >>= f = [y | x <- xs, y <- f x]
+ {-# INLINE (>>) #-}
+ (>>) = (*>)
+
+-- | Combines lists by concatenation, starting from the empty list.
+--
+-- @since 2.01
+instance Alternative [] where
+ empty = []
+ (<|>) = (++)
+-- | @since 4.9.0.0
+instance Functor NonEmpty where
+ fmap f ~(a :| as) = f a :| fmap f as
+ b <$ ~(_ :| as) = b :| (b <$ as)
+
+-- | @since 4.9.0.0
+instance Applicative NonEmpty where
+ pure a = a :| []
+ (<*>) = ap
+ liftA2 = liftM2
+
+-- | @since 4.9.0.0
+instance Monad NonEmpty where
+ ~(a :| as) >>= f = b :| (bs ++ bs')
+ where b :| bs = f a
+ bs' = as >>= toList . f
+ toList ~(c :| cs) = c : cs
+
+-- | A monoid on applicative functors.
+--
+-- If defined, 'some' and 'many' should be the least solutions
+-- of the equations:
+--
+-- * @'some' v = (:) 'Prelude.<$>' v '<*>' 'many' v@
+--
+-- * @'many' v = 'some' v '<|>' 'pure' []@
+class Applicative f => Alternative f where
+ -- | The identity of '<|>'
+ empty :: f a
+ -- | An associative binary operation
+ (<|>) :: f a -> f a -> f a
+
+ -- | One or more.
+ some :: f a -> f [a]
+ some v = some_v
+ where
+ many_v = some_v <|> pure []
+ some_v = liftA2 (:) v many_v
+
+ -- | Zero or more.
+ many :: f a -> f [a]
+ many v = many_v
+ where
+ many_v = some_v <|> pure []
+ some_v = liftA2 (:) v many_v
+
+
+-- | Picks the leftmost 'Just' value, or, alternatively, 'Nothing'.
+--
+-- @since 2.01
+instance Alternative Maybe where
+ empty = Nothing
+ Nothing <|> r = r
+ l <|> _ = l
+
+-- -----------------------------------------------------------------------------
+-- The MonadPlus class definition
+
+-- | Monads that also support choice and failure.
+class (Alternative m, Monad m) => MonadPlus m where
+ -- | The identity of 'mplus'. It should also satisfy the equations
+ --
+ -- > mzero >>= f = mzero
+ -- > v >> mzero = mzero
+ --
+ -- The default definition is
+ --
+ -- @
+ -- mzero = 'empty'
+ -- @
+ mzero :: m a
+ mzero = empty
+
+ -- | An associative operation. The default definition is
+ --
+ -- @
+ -- mplus = ('<|>')
+ -- @
+ mplus :: m a -> m a -> m a
+ mplus = (<|>)
+
+-- | Picks the leftmost 'Just' value, or, alternatively, 'Nothing'.
+--
+-- @since 2.01
+instance MonadPlus Maybe
+
+-- | Combines lists by concatenation, starting from the empty list.
+--
+-- @since 2.01
+instance MonadPlus []
+
+----------------------------------------------
+-- Functor/Applicative/Monad instances for IO
+----------------------------------------------
+
+-- | @since 2.01
+instance Functor IO where
+ fmap f x = x >>= (pure . f)
+
+-- | @since 2.01
+instance Applicative IO where
+ {-# INLINE pure #-}
+ {-# INLINE (*>) #-}
+ {-# INLINE liftA2 #-}
+ pure = returnIO
+ (*>) = thenIO
+ (<*>) = ap
+ liftA2 = liftM2
+
+-- | @since 2.01
+instance Monad IO where
+ {-# INLINE (>>) #-}
+ {-# INLINE (>>=) #-}
+ (>>) = (*>)
+ (>>=) = bindIO
+
+-- | Takes the first non-throwing 'IO' action\'s result.
+-- 'empty' throws an exception.
+--
+-- @since 4.9.0.0
+instance Alternative IO where
+ empty = failIO "mzero"
+ (<|>) = mplusIO
+
+-- | Takes the first non-throwing 'IO' action\'s result.
+-- 'mzero' throws an exception.
+--
+-- @since 4.9.0.0
+instance MonadPlus IO
+
+returnIO :: a -> IO a
+returnIO x = IO (\ s -> (# s, x #))
+
+bindIO :: IO a -> (a -> IO b) -> IO b
+bindIO (IO m) k = IO (\ s -> case m s of (# new_s, a #) -> unIO (k a) new_s)
+
+thenIO :: IO a -> IO b -> IO b
+thenIO (IO m) k = IO (\ s -> case m s of (# new_s, _ #) -> unIO k new_s)
+
+-- Note that it is import that we do not SOURCE import this as
+-- its demand signature encodes knowledge of its bottoming
+-- behavior, which can expose useful simplifications. See
+-- #16588.
+failIO :: String -> IO a
+failIO s = IO (raiseIO# (mkUserError s))
+
+unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
+unIO (IO a) = a
+
=====================================
libraries/base/GHC/Base/List.hs
=====================================
@@ -0,0 +1,233 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MagicHash #-}
+
+-- -Wno-orphans is needed for things like:
+-- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+module GHC.Base.List
+ ( foldr
+ , build
+ , augment
+ , map
+ , mapFB
+ , (++)
+ ) where
+
+import GHC.CString
+import GHC.Base.FunOps ((.))
+import GHC.Prim (coerce)
+
+infixr 5 ++
+
+-- | 'foldr', applied to a binary operator, a starting value (typically
+-- the right-identity of the operator), and a list, reduces the list
+-- using the binary operator, from right to left:
+--
+-- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...)
+
+foldr :: (a -> b -> b) -> b -> [a] -> b
+-- foldr _ z [] = z
+-- foldr f z (x:xs) = f x (foldr f z xs)
+{-# INLINE [0] foldr #-}
+-- Inline only in the final stage, after the foldr/cons rule has had a chance
+-- Also note that we inline it when it has *two* parameters, which are the
+-- ones we are keen about specialising!
+foldr k z = go
+ where
+ go [] = z
+ go (y:ys) = y `k` go ys
+
+-- | A list producer that can be fused with 'foldr'.
+-- This function is merely
+--
+-- > build g = g (:) []
+--
+-- but GHC's simplifier will transform an expression of the form
+-- @'foldr' k z ('build' g)@, which may arise after inlining, to @g k z@,
+-- which avoids producing an intermediate list.
+
+build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
+{-# INLINE [1] build #-}
+ -- The INLINE is important, even though build is tiny,
+ -- because it prevents [] getting inlined in the version that
+ -- appears in the interface file. If [] *is* inlined, it
+ -- won't match with [] appearing in rules in an importing module.
+ --
+ -- The "1" says to inline in phase 1
+
+build g = g (:) []
+
+-- | A list producer that can be fused with 'foldr'.
+-- This function is merely
+--
+-- > augment g xs = g (:) xs
+--
+-- but GHC's simplifier will transform an expression of the form
+-- @'foldr' k z ('augment' g xs)@, which may arise after inlining, to
+-- @g k ('foldr' k z xs)@, which avoids producing an intermediate list.
+
+augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
+{-# INLINE [1] augment #-}
+augment g xs = g (:) xs
+
+{-# RULES
+"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (build g) = g k z
+
+"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (augment g xs) = g k (foldr k z xs)
+
+"foldr/id" foldr (:) [] = \x -> x
+"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys
+ -- Only activate this from phase 1, because that's
+ -- when we disable the rule that expands (++) into foldr
+
+-- The foldr/cons rule looks nice, but it can give disastrously
+-- bloated code when compiling
+-- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ]
+-- i.e. when there are very very long literal lists
+-- So I've disabled it for now. We could have special cases
+-- for short lists, I suppose.
+-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
+
+"foldr/single" forall k z x. foldr k z [x] = k x z
+"foldr/nil" forall k z. foldr k z [] = z
+
+"foldr/cons/build" forall k z x (g::forall b. (a->b->b) -> b -> b) .
+ foldr k z (x:build g) = k x (g k z)
+
+"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
+ (h::forall b. (a->b->b) -> b -> b) .
+ augment g (build h) = build (\c n -> g c (h c n))
+"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) .
+ augment g [] = build g
+ #-}
+
+-- This rule is true, but not (I think) useful:
+-- augment g (augment h t) = augment (\cn -> g c (h c n)) t
+
+----------------------------------------------
+-- map
+----------------------------------------------
+
+-- | \(\mathcal{O}(n)\). 'map' @f xs@ is the list obtained by applying @f@ to
+-- each element of @xs@, i.e.,
+--
+-- > map f [x1, x2, ..., xn] == [f x1, f x2, ..., f xn]
+-- > map f [x1, x2, ...] == [f x1, f x2, ...]
+--
+-- >>> map (+1) [1, 2, 3]
+-- [2,3,4]
+map :: (a -> b) -> [a] -> [b]
+{-# NOINLINE [0] map #-}
+ -- We want the RULEs "map" and "map/coerce" to fire first.
+ -- map is recursive, so won't inline anyway,
+ -- but saying so is more explicit, and silences warnings
+map _ [] = []
+map f (x:xs) = f x : map f xs
+
+-- Note eta expanded
+mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
+{-# INLINE [0] mapFB #-} -- See Note [Inline FB functions] in GHC.List
+mapFB c f = \x ys -> c (f x) ys
+
+{- Note [The rules for map]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rules for map work like this.
+
+* Up to (but not including) phase 1, we use the "map" rule to
+ rewrite all saturated applications of map with its build/fold
+ form, hoping for fusion to happen.
+
+ In phase 1 and 0, we switch off that rule, inline build, and
+ switch on the "mapList" rule, which rewrites the foldr/mapFB
+ thing back into plain map.
+
+ It's important that these two rules aren't both active at once
+ (along with build's unfolding) else we'd get an infinite loop
+ in the rules. Hence the activation control below.
+
+* This same pattern is followed by many other functions:
+ e.g. append, filter, iterate, repeat, etc. in GHC.List
+
+ See also Note [Inline FB functions] in GHC.List
+
+* The "mapFB" rule optimises compositions of map
+
+* The "mapFB/id" rule gets rid of 'map id' calls.
+ You might think that (mapFB c id) will turn into c simply
+ when mapFB is inlined; but before that happens the "mapList"
+ rule turns
+ (foldr (mapFB (:) id) [] a
+ back into
+ map id
+ Which is not very clever.
+
+* Any similarity to the Functor laws for [] is expected.
+-}
+
+{-# RULES
+"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
+"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f
+"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
+"mapFB/id" forall c. mapFB c (\x -> x) = c
+ #-}
+
+-- See Breitner, Eisenberg, Peyton Jones, and Weirich, "Safe Zero-cost
+-- Coercions for Haskell", section 6.5:
+-- http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/coercible.pdf
+
+{-# RULES "map/coerce" [1] map coerce = coerce #-}
+-- See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt
+
+----------------------------------------------
+-- append
+----------------------------------------------
+
+-- | Append two lists, i.e.,
+--
+-- > [x1, ..., xm] ++ [y1, ..., yn] == [x1, ..., xm, y1, ..., yn]
+-- > [x1, ..., xm] ++ [y1, ...] == [x1, ..., xm, y1, ...]
+--
+-- If the first list is not finite, the result is the first list.
+--
+-- WARNING: This function takes linear time in the number of elements of the
+-- first list.
+
+(++) :: [a] -> [a] -> [a]
+{-# NOINLINE [2] (++) #-}
+ -- Give time for the RULEs for (++) to fire in InitialPhase
+ -- It's recursive, so won't inline anyway,
+ -- but saying so is more explicit
+(++) [] ys = ys
+(++) (x:xs) ys = x : xs ++ ys
+
+{-# RULES
+"++/literal" forall x. (++) (unpackCString# x) = unpackAppendCString# x
+"++/literal_utf8" forall x. (++) (unpackCStringUtf8# x) = unpackAppendCStringUtf8# x #-}
+
+{-# RULES
+"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
+ #-}
+
+-- Rules for C strings (the functions themselves are now in GHC.CString)
+{-# RULES
+"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a)
+"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a
+"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n
+"unpack-append-nil" forall a . unpackAppendCString# a [] = unpackCString# a
+
+"unpack-utf8" [~1] forall a . unpackCStringUtf8# a = build (unpackFoldrCStringUtf8# a)
+"unpack-list-utf8" [1] forall a . unpackFoldrCStringUtf8# a (:) [] = unpackCStringUtf8# a
+"unpack-append-utf8" forall a n . unpackFoldrCStringUtf8# a (:) n = unpackAppendCStringUtf8# a n
+"unpack-append-nil-utf8" forall a . unpackAppendCStringUtf8# a [] = unpackCStringUtf8# a
+
+-- There's a built-in rule (in GHC.Core.Op.ConstantFold) for
+-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
+
+-- See also the Note [String literals in GHC] in CString.hs
+
+ #-}
=====================================
libraries/base/GHC/Base/NonEmpty.hs
=====================================
@@ -0,0 +1,32 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Base.NonEmpty
+-- Copyright : (c) The University of Glasgow, 1992-2002
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc at haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC extensions)
+--
+-- The 'NonEmpty' type.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Base.NonEmpty
+ ( NonEmpty(..)
+ ) where
+
+import GHC.Classes
+
+infixr 5 :|
+
+-- | Non-empty (and non-strict) list type.
+--
+-- @since 4.9.0.0
+data NonEmpty a = a :| [a]
+ deriving ( Eq -- ^ @since 4.9.0.0
+ , Ord -- ^ @since 4.9.0.0
+ )
=====================================
libraries/base/GHC/Base/Semigroup.hs
=====================================
@@ -0,0 +1,325 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE EmptyDataDeriving #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE Unsafe #-}
+
+-- -Wno-orphans is needed for things like:
+-- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Base.Semigroup
+-- Copyright : (c) The University of Glasgow, 1992-2002
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc at haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC extensions)
+--
+-- 'Monoid' and 'Semigroup' classes.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Base.Semigroup
+ ( Semigroup(..)
+ , Monoid(..)
+ ) where
+
+import GHC.Types
+import GHC.Maybe
+import GHC.Base.List (foldr, map, (++))
+import GHC.Base.NonEmpty
+import GHC.Tuple (Solo (MkSolo)) -- Note [Depend on GHC.Tuple]
+import {-# SOURCE #-} GHC.Real (Integral)
+import {-# SOURCE #-} Data.Semigroup.Internal ( stimesDefault
+ , stimesMaybe
+ , stimesList
+ , stimesIdempotentMonoid
+ )
+
+infixr 6 <>
+
+-- | The class of semigroups (types with an associative binary operation).
+--
+-- Instances should satisfy the following:
+--
+-- [Associativity] @x '<>' (y '<>' z) = (x '<>' y) '<>' z@
+--
+-- You can alternatively define `sconcat` instead of (`<>`), in which case the
+-- laws are:
+--
+-- [Unit]: @'sconcat' ('pure' x) = x@
+-- [Multiplication]: @'sconcat' ('join' xss) = 'sconcat' ('fmap' 'sconcat' xss)@
+--
+-- @since 4.9.0.0
+class Semigroup a where
+ -- | An associative operation.
+ --
+ -- >>> [1,2,3] <> [4,5,6]
+ -- [1,2,3,4,5,6]
+ (<>) :: a -> a -> a
+ a <> b = sconcat (a :| [ b ])
+
+ -- | Reduce a non-empty list with '<>'
+ --
+ -- The default definition should be sufficient, but this can be
+ -- overridden for efficiency.
+ --
+ -- >>> import Data.List.NonEmpty (NonEmpty (..))
+ -- >>> sconcat $ "Hello" :| [" ", "Haskell", "!"]
+ -- "Hello Haskell!"
+ sconcat :: NonEmpty a -> a
+ sconcat (a :| as) = go a as where
+ go b (c:cs) = b <> go c cs
+ go b [] = b
+
+ -- | Repeat a value @n@ times.
+ --
+ -- Given that this works on a 'Semigroup' it is allowed to fail if
+ -- you request 0 or fewer repetitions, and the default definition
+ -- will do so.
+ --
+ -- By making this a member of the class, idempotent semigroups
+ -- and monoids can upgrade this to execute in \(\mathcal{O}(1)\) by
+ -- picking @stimes = 'Data.Semigroup.stimesIdempotent'@ or @stimes =
+ -- 'stimesIdempotentMonoid'@ respectively.
+ --
+ -- >>> stimes 4 [1]
+ -- [1,1,1,1]
+ stimes :: Integral b => b -> a -> a
+ stimes = stimesDefault
+
+ {-# MINIMAL (<>) | sconcat #-}
+
+-- | The class of monoids (types with an associative binary operation that
+-- has an identity). Instances should satisfy the following:
+--
+-- [Right identity] @x '<>' 'mempty' = x@
+-- [Left identity] @'mempty' '<>' x = x@
+-- [Associativity] @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ ('Semigroup' law)
+-- [Concatenation] @'mconcat' = 'foldr' ('<>') 'mempty'@
+--
+-- You can alternatively define `mconcat` instead of `mempty`, in which case the
+-- laws are:
+--
+-- [Unit]: @'mconcat' ('pure' x) = x@
+-- [Multiplication]: @'mconcat' ('join' xss) = 'mconcat' ('fmap' 'mconcat' xss)@
+-- [Subclass]: @'mconcat' ('toList' xs) = 'sconcat' xs@
+--
+-- The method names refer to the monoid of lists under concatenation,
+-- but there are many other instances.
+--
+-- Some types can be viewed as a monoid in more than one way,
+-- e.g. both addition and multiplication on numbers.
+-- In such cases we often define @newtype at s and make those instances
+-- of 'Monoid', e.g. 'Data.Semigroup.Sum' and 'Data.Semigroup.Product'.
+--
+-- __NOTE__: 'Semigroup' is a superclass of 'Monoid' since /base-4.11.0.0/.
+class Semigroup a => Monoid a where
+ -- | Identity of 'mappend'
+ --
+ -- >>> "Hello world" <> mempty
+ -- "Hello world"
+ mempty :: a
+ mempty = mconcat []
+ {-# INLINE mempty #-}
+
+ -- | An associative operation
+ --
+ -- __NOTE__: This method is redundant and has the default
+ -- implementation @'mappend' = ('<>')@ since /base-4.11.0.0/.
+ -- Should it be implemented manually, since 'mappend' is a synonym for
+ -- ('<>'), it is expected that the two functions are defined the same
+ -- way. In a future GHC release 'mappend' will be removed from 'Monoid'.
+ mappend :: a -> a -> a
+ mappend = (<>)
+ {-# INLINE mappend #-}
+
+ -- | Fold a list using the monoid.
+ --
+ -- For most types, the default definition for 'mconcat' will be
+ -- used, but the function is included in the class definition so
+ -- that an optimized version can be provided for specific types.
+ --
+ -- >>> mconcat ["Hello", " ", "Haskell", "!"]
+ -- "Hello Haskell!"
+ mconcat :: [a] -> a
+ mconcat = foldr mappend mempty
+ {-# INLINE mconcat #-}
+ -- INLINE in the hope of fusion with mconcat's argument (see !4890)
+
+ {-# MINIMAL mempty | mconcat #-}
+
+-- | @since 4.9.0.0
+instance Semigroup [a] where
+ (<>) = (++)
+ {-# INLINE (<>) #-}
+
+ stimes = stimesList
+
+-- | @since 2.01
+instance Monoid [a] where
+ {-# INLINE mempty #-}
+ mempty = []
+ {-# INLINE mconcat #-}
+ mconcat xss = [x | xs <- xss, x <- xs]
+-- See Note: [List comprehensions and inlining]
+
+
+{-
+Note: [List comprehensions and inlining]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The list monad operations are traditionally described in terms of concatMap:
+
+xs >>= f = concatMap f xs
+
+Similarly, mconcat for lists is just concat. Here in Base, however, we don't
+have concatMap, and we'll refrain from adding it here so it won't have to be
+hidden in imports. Instead, we use GHC's list comprehension desugaring
+mechanism to define mconcat and the Applicative and Monad instances for lists.
+We mark them INLINE because the inliner is not generally too keen to inline
+build forms such as the ones these desugar to without our insistence. Defining
+these using list comprehensions instead of foldr has an additional potential
+benefit, as described in compiler/GHC/HsToCore/ListComp.hs: if optimizations
+needed to make foldr/build forms efficient are turned off, we'll get reasonably
+efficient translations anyway.
+-}
+
+-- | @since 4.9.0.0
+instance Semigroup (NonEmpty a) where
+ (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs)
+
+-- | @since 4.9.0.0
+instance Semigroup b => Semigroup (a -> b) where
+ f <> g = \x -> f x <> g x
+ stimes n f e = stimes n (f e)
+
+-- | @since 2.01
+instance Monoid b => Monoid (a -> b) where
+ mempty _ = mempty
+ -- If `b` has a specialised mconcat, use that, rather than the default
+ -- mconcat, which can be much less efficient. Inline in the hope that
+ -- it may result in list fusion.
+ mconcat = \fs x -> mconcat (map (\f -> f x) fs)
+ {-# INLINE mconcat #-}
+
+-- | @since 4.9.0.0
+instance Semigroup () where
+ _ <> _ = ()
+ sconcat _ = ()
+ stimes _ _ = ()
+
+-- | @since 2.01
+instance Monoid () where
+ -- Should it be strict?
+ mempty = ()
+ mconcat _ = ()
+
+-- | @since 4.15
+instance Semigroup a => Semigroup (Solo a) where
+ MkSolo a <> MkSolo b = MkSolo (a <> b)
+ stimes n (MkSolo a) = MkSolo (stimes n a)
+
+-- | @since 4.15
+instance Monoid a => Monoid (Solo a) where
+ mempty = MkSolo mempty
+
+-- | @since 4.9.0.0
+instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
+ (a,b) <> (a',b') = (a<>a',b<>b')
+ stimes n (a,b) = (stimes n a, stimes n b)
+
+-- | @since 2.01
+instance (Monoid a, Monoid b) => Monoid (a,b) where
+ mempty = (mempty, mempty)
+
+-- | @since 4.9.0.0
+instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where
+ (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')
+ stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)
+
+-- | @since 2.01
+instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
+ mempty = (mempty, mempty, mempty)
+
+-- | @since 4.9.0.0
+instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)
+ => Semigroup (a, b, c, d) where
+ (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')
+ stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)
+
+-- | @since 2.01
+instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
+ mempty = (mempty, mempty, mempty, mempty)
+
+-- | @since 4.9.0.0
+instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
+ => Semigroup (a, b, c, d, e) where
+ (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
+ stimes n (a,b,c,d,e) =
+ (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)
+
+-- | @since 2.01
+instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
+ Monoid (a,b,c,d,e) where
+ mempty = (mempty, mempty, mempty, mempty, mempty)
+
+
+-- | @since 4.9.0.0
+instance Semigroup Ordering where
+ LT <> _ = LT
+ EQ <> y = y
+ GT <> _ = GT
+
+ stimes = stimesIdempotentMonoid
+
+-- lexicographical ordering
+-- | @since 2.01
+instance Monoid Ordering where
+ mempty = EQ
+
+-- | @since 4.9.0.0
+instance Semigroup a => Semigroup (Maybe a) where
+ Nothing <> b = b
+ a <> Nothing = a
+ Just a <> Just b = Just (a <> b)
+
+ stimes = stimesMaybe
+
+-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
+-- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
+-- turned into a monoid simply by adjoining an element @e@ not in @S@
+-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S at .\"
+--
+-- /Since 4.11.0/: constraint on inner @a@ value generalised from
+-- 'Monoid' to 'Semigroup'.
+--
+-- @since 2.01
+instance Semigroup a => Monoid (Maybe a) where
+ mempty = Nothing
+
+-- | @since 4.10.0.0
+instance Semigroup a => Semigroup (IO a) where
+ -- Ideally we would define this as:
+ -- (<>) = liftA2 (<>)
+ -- but this would incur an import cycle.
+ IO f <> IO g = IO (\s0 ->
+ case f s0 of
+ (# s1, x #) ->
+ case g s1 of
+ (# s2, y #) -> (# s2, x <> y #))
+
+-- | @since 4.9.0.0
+instance Monoid a => Monoid (IO a) where
+ mempty = IO (\s -> (# s, mempty #) )
+
=====================================
libraries/base/GHC/Base.hs-boot → libraries/base/GHC/Base/Semigroup.hs-boot
=====================================
@@ -1,9 +1,9 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module GHC.Base (Maybe, Semigroup, Monoid) where
+module GHC.Base.Semigroup (Semigroup, Monoid) where
-import GHC.Maybe (Maybe)
-import GHC.Types ()
+import GHC.Num.Integer () -- See Note [Depend on GHC.Num.Integer] in GHC.Base
class Semigroup a
class Monoid a
+
=====================================
libraries/base/GHC/Base/String.hs
=====================================
@@ -0,0 +1,42 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash #-}
+
+-- -Wno-orphans is needed for things like:
+-- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module GHC.Base.String
+ ( String
+ , unsafeChr
+ , ord
+ , eqString
+ ) where
+
+import GHC.Types (Char(..), Int(..), Bool(..))
+import GHC.Classes (Eq(..), (&&))
+import GHC.Prim (chr#, ord#)
+
+-- | A 'String' is a list of characters. String constants in Haskell are values
+-- of type 'String'.
+--
+-- See "Data.List" for operations on lists.
+type String = [Char]
+
+unsafeChr :: Int -> Char
+unsafeChr (I# i#) = C# (chr# i#)
+
+-- | The 'Prelude.fromEnum' method restricted to the type 'Data.Char.Char'.
+ord :: Char -> Int
+ord (C# c#) = I# (ord# c#)
+
+-- | This 'String' equality predicate is used when desugaring
+-- pattern-matches against strings.
+eqString :: String -> String -> Bool
+eqString [] [] = True
+eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2
+eqString _ _ = False
+
+{-# RULES "eqString" (==) = eqString #-}
+-- eqString also has a BuiltInRule in GHC.Core.Opt.ConstantFold:
+-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
+
=====================================
libraries/base/GHC/Base/Void.hs
=====================================
@@ -0,0 +1,50 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE EmptyDataDeriving #-}
+
+module GHC.Base.Void
+ ( Void
+ , absurd
+ , vacuous
+ ) where
+
+import GHC.Classes
+import GHC.Base.Functor
+import GHC.Base.Semigroup
+
+-- | Uninhabited data type
+--
+-- @since 4.8.0.0
+data Void deriving
+ ( Eq -- ^ @since 4.8.0.0
+ , Ord -- ^ @since 4.8.0.0
+ )
+
+-- | @since 4.9.0.0
+instance Semigroup Void where
+ a <> _ = a
+ stimes _ a = a
+
+-- | Since 'Void' values logically don't exist, this witnesses the
+-- logical reasoning tool of \"ex falso quodlibet\".
+--
+-- >>> let x :: Either Void Int; x = Right 5
+-- >>> :{
+-- case x of
+-- Right r -> r
+-- Left l -> absurd l
+-- :}
+-- 5
+--
+-- @since 4.8.0.0
+absurd :: Void -> a
+absurd a = case a of {}
+
+-- | If 'Void' is uninhabited then any 'Functor' that holds only
+-- values of type 'Void' is holding no values.
+-- It is implemented in terms of @fmap absurd at .
+--
+-- @since 4.8.0.0
+vacuous :: Functor f => f Void -> f a
+vacuous = fmap absurd
+
=====================================
libraries/base/base.cabal
=====================================
@@ -192,6 +192,13 @@ Library
GHC.Arr
GHC.ArrayArray
GHC.Base
+ GHC.Base.FunOps
+ GHC.Base.Functor
+ GHC.Base.List
+ GHC.Base.NonEmpty
+ GHC.Base.Semigroup
+ GHC.Base.String
+ GHC.Base.Void
GHC.Bits
GHC.ByteOrder
GHC.Char
=====================================
testsuite/mk/boilerplate.mk
=====================================
@@ -227,6 +227,10 @@ ifeq "$(CHECK_EXACT)" ""
CHECK_EXACT := $(abspath $(TOP)/../inplace/bin/check-exact)
endif
+ifeq "$(DUMP_DECLS)" ""
+DUMP_DECLS := $(abspath $(TOP)/../inplace/bin/dump-decls)
+endif
+
ifeq "$(COUNT_DEPS)" ""
COUNT_DEPS := $(abspath $(TOP)/../inplace/bin/count-deps)
endif
=====================================
testsuite/tests/interface-stability/Makefile
=====================================
@@ -0,0 +1,6 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+exports_% :
+ "$(DUMP_DECLS)" "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" $*
=====================================
testsuite/tests/interface-stability/README.mkd
=====================================
@@ -0,0 +1,11 @@
+# Interface stability testing
+
+The tests in this directory verify that the interfaces of exposed by GHC's
+core libraries do not inadvertently change. They use the `utils/dump-decls`
+utility to dump all exported declarations of all exposed modules for the
+following packages:
+
+ * base
+
+These are compared against the expected exports in the test's corresponding
+`.stdout` file.
=====================================
testsuite/tests/interface-stability/all.T
=====================================
@@ -0,0 +1,7 @@
+def check_package(pkg_name):
+ test(f'{pkg_name}-exports',
+ req_hadrian_deps(['test:dump-decls']),
+ makefile_test,
+ [f'exports_{pkg_name}'])
+
+check_package('base')
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
The diff for this file was not included because it is too large.
=====================================
utils/dump-decls/Main.hs
=====================================
@@ -0,0 +1,182 @@
+module Main where
+
+import GHC
+import GHC.Core.InstEnv (instEnvElts, instanceHead)
+import GHC.Core.TyCo.FVs (tyConsOfType)
+import GHC.Driver.Ppr (showSDocForUser)
+import GHC.Unit.State (lookupUnitId, lookupPackageName)
+import GHC.Unit.Info (UnitInfo, unitExposedModules, PackageName(..))
+import GHC.Data.FastString (fsLit)
+import GHC.Driver.Env (hsc_units, hscEPS)
+import GHC.Utils.Outputable
+import GHC.Types.Unique.Set (nonDetEltsUniqSet)
+import GHC.Types.TyThing (tyThingParent_maybe)
+import GHC.Types.TyThing.Ppr (pprTyThing)
+import GHC.Types.Name (nameOccName, nameModule_maybe, stableNameCmp)
+import GHC.Types.Name.Occurrence (OccName)
+import GHC.Unit.External (eps_inst_env)
+import GHC.Iface.Syntax (ShowSub(..), ShowHowMuch(..), AltPpr(..))
+import GHC.Iface.Type (ShowForAllFlag(..))
+
+import Data.Function (on)
+import Data.List (sortBy)
+import Control.Monad.IO.Class
+import System.Environment (getArgs)
+import Prelude hiding ((<>))
+
+main :: IO ()
+main = do
+ ghcRoot:pkg_names <- getArgs
+ mapM_ (run ghcRoot) pkg_names
+
+run :: FilePath -> String -> IO ()
+run root pkg_nm = runGhc (Just root) $ do
+ let args = map noLoc
+ [ "-package=" ++ pkg_nm
+ , "-dppr-cols=1000"
+ , "-fprint-explicit-runtime-reps"
+ , "-fprint-explicit-foralls"
+ ]
+ dflags <- do
+ dflags <- getSessionDynFlags
+ logger <- getLogger
+ (dflags', _fileish_args, _dynamicFlagWarnings) <-
+ GHC.parseDynamicFlags logger dflags args
+ return dflags'
+
+ _ <- setProgramDynFlags dflags
+ unit_state <- hsc_units <$> getSession
+ unit_id <- case lookupPackageName unit_state (PackageName $ fsLit pkg_nm) of
+ Just unit_id -> return unit_id
+ Nothing -> fail "failed to find package"
+ unit_info <- case lookupUnitId unit_state unit_id of
+ Just unit_info -> return unit_info
+ Nothing -> fail "unknown package"
+
+ decls_doc <- reportUnitDecls unit_info
+ insts_doc <- reportInstances
+
+ name_ppr_ctx <- GHC.getNamePprCtx
+ let rendered = showSDocForUser dflags unit_state name_ppr_ctx (vcat [decls_doc, insts_doc])
+ liftIO $ putStrLn rendered
+
+ignoredModules :: [ModuleName]
+ignoredModules =
+ map mkModuleName $ concat
+ [ unstableModules
+ , platformDependentModules
+ ]
+ where
+ unstableModules =
+ [ "GHC.Prim"
+ , "GHC.Conc.POSIX"
+ , "GHC.Conc.IO"
+ ]
+ platformDependentModules =
+ [ "System.Posix.Types"
+ , "Foreign.C.Types"
+ ]
+
+ignoredName :: Name -> Bool
+ignoredName nm
+ | Just md <- nameModule_maybe nm
+ , moduleName md `elem` ignoredModules
+ = True
+ | otherwise
+ = False
+
+ignoredTyThing :: TyThing -> Bool
+ignoredTyThing _ = False
+
+ignoredTyCon :: TyCon -> Bool
+ignoredTyCon = ignoredName . getName
+
+ignoredType :: Type -> Bool
+ignoredType = any ignoredTyCon . nonDetEltsUniqSet . tyConsOfType
+
+-- | Ignore instances whose heads mention ignored types.
+ignoredInstance :: ClsInst -> Bool
+ignoredInstance inst
+ | ignoredName $ getName cls
+ = True
+ | any ignoredType tys
+ = True
+ | otherwise
+ = False
+ where
+ (_, cls, tys) = instanceHead inst
+
+reportUnitDecls :: UnitInfo -> Ghc SDoc
+reportUnitDecls unit_info = do
+ let exposed :: [ModuleName]
+ exposed = map fst (unitExposedModules unit_info)
+ vcat <$> mapM reportModuleDecls exposed
+
+reportModuleDecls :: ModuleName -> Ghc SDoc
+reportModuleDecls modl_nm
+ | modl_nm `elem` ignoredModules = do
+ return $ vcat [ mod_header, text "-- ignored", text "" ]
+ | otherwise = do
+ modl <- GHC.lookupQualifiedModule NoPkgQual modl_nm
+ mb_mod_info <- GHC.getModuleInfo modl
+ mod_info <- case mb_mod_info of
+ Nothing -> fail "Failed to find module"
+ Just mod_info -> return mod_info
+
+ Just name_ppr_ctx <- mkNamePprCtxForModule mod_info
+ let names = GHC.modInfoExports mod_info
+ sorted_names = sortBy (compare `on` nameOccName) names
+
+ exported_occs :: [OccName]
+ exported_occs = map nameOccName names
+
+ is_exported :: OccName -> Bool
+ is_exported = (`elem` exported_occs)
+
+ things <- mapM GHC.lookupName sorted_names
+ let contents = vcat $
+ [ text "-- Safety:" <+> ppr (modInfoSafe mod_info) ] ++
+ [ pprTyThing ss thing
+ | Just thing <- things
+ , case tyThingParent_maybe thing of
+ Just parent
+ | is_exported (getOccName parent) -> False
+ _ -> True
+ , not $ ignoredTyThing thing
+ , let ss = ShowSub { ss_how_much = ShowSome is_exported (AltPpr Nothing)
+ , ss_forall = ShowForAllMust
+ }
+ ]
+
+ return $ withUserStyle name_ppr_ctx AllTheWay $
+ hang mod_header 2 contents <>
+ text ""
+ where
+ mod_header = vcat
+ [ text ""
+ , text "module" <+> ppr modl_nm <+> text "where"
+ , text ""
+ ]
+
+reportInstances :: Ghc SDoc
+reportInstances = do
+ hsc_env <- getSession
+ eps <- liftIO $ hscEPS hsc_env
+ let instances = eps_inst_env eps
+ return $ vcat $
+ [ text ""
+ , text ""
+ , text "-- Instances:"
+ ] ++
+ [ ppr inst
+ | inst <- sortBy compareInstances (instEnvElts instances)
+ , not $ ignoredInstance inst
+ ]
+
+compareInstances :: ClsInst -> ClsInst -> Ordering
+compareInstances inst1 inst2 = mconcat
+ [ stableNameCmp (getName cls1) (getName cls2)
+ ]
+ where
+ (_, cls1, _tys1) = instanceHead inst1
+ (_, cls2, _tys2) = instanceHead inst2
=====================================
utils/dump-decls/dump-decls.cabal
=====================================
@@ -0,0 +1,13 @@
+cabal-version: 2.4
+name: dump-decls
+version: 0.1.0.0
+synopsis: Dump the declarations of a package.
+license: BSD-3-Clause
+author: Ben Gamari
+maintainer: ben at smart-cactus.org
+copyright: (c) 2023 Ben Gamari
+
+executable dump-decls
+ main-is: Main.hs
+ build-depends: base, ghc
+ default-language: Haskell2010
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/acba4af8b8259a9f43655170cda3607aed10bb01...67252ef1ef1c18a5d6b0a2d4e9f910a56c248eef
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/acba4af8b8259a9f43655170cda3607aed10bb01...67252ef1ef1c18a5d6b0a2d4e9f910a56c248eef
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230519/3d29b478/attachment-0001.html>
More information about the ghc-commits
mailing list