polysemy 1.6.0.0 → 1.7.0.0

raw patch · 11 files changed

+119/−279 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +25/−1
• README.md +1/−7
• polysemy.cabal +2/−11
• src/Polysemy.hs +0/−1
• src/Polysemy/AtomicState.hs +43/−0
• src/Polysemy/Internal.hs +0/−1
• src/Polysemy/Internal/CustomErrors.hs +1/−80
• src/Polysemy/Internal/TH/Common.hs +4/−4
• src/Polysemy/Internal/TH/Effect.hs +2/−12
• src/Polysemy/Internal/Union.hs +41/−70
• test/TypeErrors.hs +0/−92

@@ -2,6 +2,30 @@  ## Unreleased +### Breaking Changes++### Other Changes+++## 1.7.0.0 (2021-11-16)++### Breaking Changes++* Added interpreters for `AtomicState` that run in terms of `State`.+* Removed `MemberWithError`+* Removed `DefiningModule`++### Other Changes++* The internal `ElemOf` proof is now implemented as an unsafe integer,+    significantly cutting down on generated core.+* Polysemy no longer emits custom type errors for ambiguous effect actions.+    These have long been rendered moot by `polysemy-plugin`, and the cases that+    they still exist are usually overeager (and wrong.)+* As a result, the core produced by `polysemy` is significantly smaller.+    Programs should see a reduction of ~20% in terms and types, and ~60% in+    coercions.+ ## 1.6.0.0 (2021-07-12)  ### Breaking Changes@@ -38,7 +62,7 @@   ([#337](https://github.com/polysemy-research/polysemy/pull/337), [#382](https://github.com/polysemy-research/polysemy/pull/382)) - Restrict the existentially quantified monad in a `Weaving` to `Sem r`   ([#333](https://github.com/polysemy-research/polysemy/pull/333), thanks to @A1kmm)-- Added `raise2Under` and `raise3Under` +- Added `raise2Under` and `raise3Under`   ([#369](https://github.com/polysemy-research/polysemy/pull/369)) - Added `Raise` and `Subsume`   ([#370](https://github.com/polysemy-research/polysemy/pull/370))

@@ -76,7 +76,7 @@  ```haskell {-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments, GADTs-           , FlexibleContexts, TypeOperators, DataKinds, PolyKinds #-}+           , FlexibleContexts, TypeOperators, DataKinds, PolyKinds, ScopedTypeVariables #-}  import Polysemy import Polysemy.Input@@ -194,12 +194,6 @@     interpret       $ \case ```--Likewise it will give you tips on what to do if you forget a `TypeApplication`-or forget to handle an effect.--Don't like helpful errors? That's OK too - just flip the `error-messages`-flag and enjoy the raw, unadulterated fury of the typesystem.  ## Necessary Language Extensions 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-version:        1.6.0.0+version:        1.7.0.0 synopsis:       Higher-order, low-boilerplate free monads. description:    Please see the README on GitHub at <https://github.com/polysemy-research/polysemy#readme> category:       Language@@ -13,7 +13,7 @@ bug-reports:    https://github.com/polysemy-research/polysemy/issues author:         Sandy Maguire maintainer:     sandy@sandymaguire.me-copyright:      2019 Sandy Maguire+copyright:      2019-2021 Sandy Maguire license:        BSD3 license-file:   LICENSE build-type:     Custom@@ -36,11 +36,6 @@   manual: True   default: False -flag error-messages-  description: Provide custom error messages-  manual: True-  default: True- library   exposed-modules:       Polysemy@@ -132,10 +127,6 @@   if impl(ghc < 8.2.2)     build-depends:         unsupported-ghc-version >1 && <1-  if flag(error-messages)-    cpp-options: -DCABAL_SERIOUSLY_CMON_MATE-  else-    cpp-options: -DNO_ERROR_MESSAGES   default-language: Haskell2010  test-suite polysemy-test

@@ -2,7 +2,6 @@   ( -- * Core Types     Sem ()   , Member-  , MemberWithError   , Members      -- * Running Sem

@@ -18,6 +18,9 @@   , runAtomicStateTVar   , atomicStateToIO   , atomicStateToState+  , runAtomicStateViaState+  , evalAtomicStateViaState+  , execAtomicStateViaState   ) where  @@ -170,3 +173,43 @@     return a   AtomicGet -> get {-# INLINE atomicStateToState #-}++------------------------------------------------------------------------------+-- | Run an 'AtomicState' with local state semantics, discarding+-- the notion of atomicity, by transforming it into 'State' and running it+-- with the provided initial state.+--+--+-- @since v1.7.0.0+runAtomicStateViaState :: s+                       -> Sem (AtomicState s ': r) a+                       -> Sem r (s, a)+runAtomicStateViaState s =+  runState s . atomicStateToState . raiseUnder+{-# INLINE runAtomicStateViaState #-}++------------------------------------------------------------------------------+-- | Evaluate an 'AtomicState' with local state semantics, discarding+-- the notion of atomicity, by transforming it into 'State' and running it+-- with the provided initial state.+--+-- @since v1.7.0.0+evalAtomicStateViaState :: s+                        -> Sem (AtomicState s ': r) a+                        -> Sem r a+evalAtomicStateViaState s =+  evalState s . atomicStateToState . raiseUnder+{-# INLINE evalAtomicStateViaState #-}++------------------------------------------------------------------------------+-- | Execute an 'AtomicState' with local state semantics, discarding+-- the notion of atomicity, by transforming it into 'State' and running it+-- with the provided initial state.+--+-- @since v1.7.0.0+execAtomicStateViaState :: s+                        -> Sem (AtomicState s ': r) a+                        -> Sem r s+execAtomicStateViaState s =+  execState s . atomicStateToState . raiseUnder+{-# INLINE execAtomicStateViaState #-}

@@ -11,7 +11,6 @@ module Polysemy.Internal   ( Sem (..)   , Member-  , MemberWithError   , Members   , send   , sendUsing

@@ -7,12 +7,8 @@ {-# OPTIONS_HADDOCK not-home #-}  module Polysemy.Internal.CustomErrors-  ( AmbiguousSend-  , WhenStuck+  ( WhenStuck   , FirstOrder-  , UnhandledEffect-  , DefiningModule-  , DefiningModuleForEffect   , type (<>)   , type (%)   ) where@@ -25,18 +21,6 @@ import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck)  ---------------------------------------------------------------------------------- | The module this effect was originally defined in. This type family is used--- only for providing better error messages.------ Calls to 'Polysemy.Internal.TH.Effect.makeSem' will automatically give--- instances of 'DefiningModule'.-type family DefiningModule (t :: k) :: Symbol--type family DefiningModuleForEffect (e :: k) :: Symbol where-  DefiningModuleForEffect (e a) = DefiningModuleForEffect e-  DefiningModuleForEffect e     = DefiningModule e- -- These are taken from type-errors-pretty because it's not in stackage for 9.0.1 -- See https://github.com/polysemy-research/polysemy/issues/401 type family ToErrorMessage (t :: k) :: ErrorMessage where@@ -77,51 +61,6 @@   ShowRQuoted 'ConsR  r = ShowTypeBracketed r  -type AmbigousEffectMessage (rstate :: EffectRowCtor)-                           (r :: EffectRow)-                           (e :: k)-                           (t :: Effect)-                           (vs :: [Type])-  = "Ambiguous use of effect '" <> e <> "'"-  % "Possible fix:"-  % "  add (Member (" <> t <> ") " <> ShowRQuoted rstate r <> ") to the context of "-  % "    the type signature"-  % "If you already have the constraint you want, instead"-  % "  add a type application to specify"-  % "    " <> PrettyPrintList vs <> " directly, or activate polysemy-plugin which"-  % "      can usually infer the type correctly."--type AmbiguousSend e r =-      (IfStuck r-        (AmbiguousSendError 'TyVarR r e)-        (Pure (AmbiguousSendError (UnstuckRState r) r e)))---type family AmbiguousSendError rstate r e where-  AmbiguousSendError rstate r (e a b c d f) =-    TypeError (AmbigousEffectMessage rstate r e (e a b c d f) '[a, b c d f])--  AmbiguousSendError rstate r (e a b c d) =-    TypeError (AmbigousEffectMessage rstate r e (e a b c d) '[a, b c d])--  AmbiguousSendError rstate r (e a b c) =-    TypeError (AmbigousEffectMessage rstate r e (e a b c) '[a, b c])--  AmbiguousSendError rstate r (e a b) =-    TypeError (AmbigousEffectMessage rstate r e (e a b) '[a, b])--  AmbiguousSendError rstate r (e a) =-    TypeError (AmbigousEffectMessage rstate r e (e a) '[a])--  AmbiguousSendError rstate r e =-    TypeError-        ( "Could not deduce: (Member " <>  e <> " " <> ShowRQuoted rstate r <> ") "-        % "Fix:"-        % "  add (Member " <>  e <> " " <> r <> ") to the context of"-        % "    the type signature"-        )-- data FirstOrderErrorFcf :: k -> Symbol -> Exp Constraint type instance Eval (FirstOrderErrorFcf e fn) = $(te[t|     UnlessPhantom@@ -136,24 +75,6 @@ -- | This constraint gives helpful error messages if you attempt to use a -- first-order combinator with a higher-order type. type FirstOrder (e :: Effect) fn = UnlessStuck e (FirstOrderErrorFcf e fn)------------------------------------------------------------------------------------ | Unhandled effects-type UnhandledEffectMsg e-  = "Unhandled effect '" <> e <> "'"-  % "Probable fix:"-  % "  add an interpretation for '" <> e <> "'"--type CheckDocumentation e-  = "  If you are looking for inspiration, try consulting"-  % "    the documentation for module '" <> DefiningModuleForEffect e <> "'"--type family UnhandledEffect e where-  UnhandledEffect e =-    IfStuck (DefiningModule e)-            (TypeError (UnhandledEffectMsg e))-            (DoError (UnhandledEffectMsg e ':$$: CheckDocumentation e))   data DoError :: ErrorMessage -> Exp k

@@ -33,7 +33,7 @@ import           Language.Haskell.TH.Datatype import           Language.Haskell.TH.PprLib import           Polysemy.Internal (Sem, send)-import           Polysemy.Internal.Union (MemberWithError)+import           Polysemy.Internal.Union (Member)  #if __GLASGOW_HASKELL__ >= 804 import           Prelude hiding ((<>))@@ -71,11 +71,11 @@ ------------------------------------------------------------------------------ -- | Given an name of datatype or some of it's constructors/fields, return -- datatype's name together with info about it's constructors.-getEffectMetadata :: Name -> Q (Name, [ConLiftInfo])+getEffectMetadata :: Name -> Q [ConLiftInfo] getEffectMetadata type_name = do   dt_info  <- reifyDatatype type_name   cl_infos <- traverse makeCLInfo $ constructorName <$> datatypeCons dt_info-  pure (datatypeName dt_info, cl_infos)+  pure cl_infos   ------------------------------------------------------------------------------@@ -157,7 +157,7 @@ -- | @'makeMemberConstraint'' r type@ will produce a @Member type r@ -- constraint. makeMemberConstraint' :: Name -> Type -> Pred-makeMemberConstraint' r eff = classPred ''MemberWithError [eff, VarT r]+makeMemberConstraint' r eff = classPred ''Member [eff, VarT r]   ------------------------------------------------------------------------------

@@ -32,7 +32,6 @@ import Control.Monad import Language.Haskell.TH import Language.Haskell.TH.Datatype-import Polysemy.Internal.CustomErrors (DefiningModule) import Polysemy.Internal.TH.Common  @@ -123,20 +122,11 @@ genFreer :: Bool -> Name -> Q [Dec] genFreer should_mk_sigs type_name = do   checkExtensions [ScopedTypeVariables, FlexibleContexts, DataKinds]-  (dt_name, cl_infos) <- getEffectMetadata type_name-  tyfams_on  <- isExtEnabled TypeFamilies-  def_mod_fi <- sequence [ tySynInstDCompat-                             ''DefiningModule-                             Nothing-                             [pure $ ConT dt_name]-                             (LitT . StrTyLit . loc_module <$> location)-                         | tyfams_on-                         ]+  cl_infos <- getEffectMetadata type_name   decs <- traverse (genDec should_mk_sigs) cl_infos    let sigs = if should_mk_sigs then genSig <$> cl_infos else []--  pure $ join $ def_mod_fi : sigs ++ decs+  pure $ join $ sigs ++ decs   ------------------------------------------------------------------------------

@@ -6,10 +6,13 @@ {-# LANGUAGE FunctionalDependencies  #-} {-# LANGUAGE InstanceSigs            #-} {-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE PatternSynonyms         #-}+{-# LANGUAGE RoleAnnotations         #-} {-# LANGUAGE StrictData              #-} {-# LANGUAGE TypeFamilies            #-} {-# LANGUAGE UndecidableInstances    #-} {-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns            #-}  {-# OPTIONS_HADDOCK not-home #-} @@ -17,7 +20,6 @@   ( Union (..)   , Weaving (..)   , Member-  , MemberWithError   , weave   , hoist   -- * Building Unions@@ -33,7 +35,7 @@   , absurdU   , decompCoerce   -- * Witnesses-  , ElemOf (..)+  , ElemOf (Here, There)   , membership   , sameMember   -- * Checking membership@@ -53,10 +55,7 @@ import Polysemy.Internal.Kind import {-# SOURCE #-} Polysemy.Internal import Polysemy.Internal.Sing (SList (SEnd, SCons))--#ifndef NO_ERROR_MESSAGES-import Polysemy.Internal.CustomErrors-#endif+import Unsafe.Coerce (unsafeCoerce)   ------------------------------------------------------------------------------@@ -133,43 +132,7 @@   Union w $ Weaving e s (f' . nt) f v {-# INLINE hoist #-} - --------------------------------------------------------------------------------- | A proof that the effect @e@ is available somewhere inside of the effect--- stack @r@.-type Member e r = MemberNoError e r----------------------------------------------------------------------------------- | Like 'Member', but will produce an error message if the types are--- ambiguous. This is the constraint used for actions generated by--- 'Polysemy.makeSem'.------ /Be careful with this./ Due to quirks of 'GHC.TypeLits.TypeError',--- the custom error messages emitted by this can potentially override other,--- more helpful error messages.--- See the discussion in--- <https://github.com/polysemy-research/polysemy/issues/227 Issue #227>.------ @since 1.2.3.0-type MemberWithError e r =-  ( MemberNoError e r-#ifndef NO_ERROR_MESSAGES-    -- NOTE: The plugin explicitly pattern matches on-    -- `WhenStuck (LocateEffect _ r) _`, so if you change this, make sure to change-    -- the corresponding implementation in-    -- Polysemy.Plugin.Fundep.solveBogusError-  , WhenStuck (LocateEffect e r) (AmbiguousSend e r)-#endif-  )--type MemberNoError e r =-  ( Find e r-#ifndef NO_ERROR_MESSAGES-  , LocateEffect e r ~ '()-#endif-  )-------------------------------------------------------------------------------- -- | A proof that @e@ is an element of @r@. -- -- Due to technical reasons, @'ElemOf' e r@ is not powerful enough to@@ -177,12 +140,37 @@ -- into @r@ by using 'Polysemy.Internal.subsumeUsing'. -- -- @since 1.3.0.0-data ElemOf e r where-  -- | @e@ is located at the head of the list.-  Here  :: ElemOf e (e ': r)-  -- | @e@ is located somewhere in the tail of the list.-  There :: ElemOf e r -> ElemOf e (e' ': r)+type role ElemOf nominal nominal+newtype ElemOf (e :: k) (r :: [k]) = UnsafeMkElemOf Int +data MatchHere e r where+  MHYes :: MatchHere e (e ': r)+  MHNo  :: MatchHere e r++data MatchThere e r where+  MTYes :: ElemOf e r -> MatchThere e (e' ': r)+  MTNo  :: MatchThere e r++matchHere :: forall e r. ElemOf e r -> MatchHere e r+matchHere (UnsafeMkElemOf 0) = unsafeCoerce $ MHYes+matchHere _ = MHNo++matchThere :: forall e r. ElemOf e r -> MatchThere e r+matchThere (UnsafeMkElemOf 0) = MTNo+matchThere (UnsafeMkElemOf e) = unsafeCoerce $ MTYes $ UnsafeMkElemOf $ e - 1++pattern Here :: () => (r ~ (e ': r')) => ElemOf e r+pattern Here <- (matchHere -> MHYes)+  where+    Here = UnsafeMkElemOf 0++pattern There :: () => (r' ~ (e' ': r)) => ElemOf e r -> ElemOf e r'+pattern There e <- (matchThere -> MTYes e)+  where+    There (UnsafeMkElemOf e) = UnsafeMkElemOf $ e + 1++{-# COMPLETE Here, There #-}+ ------------------------------------------------------------------------------ -- | Checks if two membership proofs are equal. If they are, then that means -- that the effects for which membership is proven must also be equal.@@ -200,26 +188,15 @@   Nothing  ---------------------------------------------------------------------------------- | Used to detect ambiguous uses of effects. If @r@ isn't concrete,--- and we haven't been given @'LocateEffect' e r ~ '()@ from a--- @'Member' e r@ constraint, then @'LocateEffect' e r@ will get stuck.-type family LocateEffect (t :: k) (ts :: [k]) :: () where-#ifndef NO_ERROR_MESSAGES-  LocateEffect t '[] = UnhandledEffect t-#endif-  LocateEffect t (t ': ts) = '()-  LocateEffect t (u ': ts) = LocateEffect t ts--class Find (t :: k) (r :: [k]) where+class Member (t :: Effect) (r :: EffectRow) where   membership' :: ElemOf t r -instance {-# OVERLAPPING #-} Find t (t ': z) where+instance {-# OVERLAPPING #-} Member t (t ': z) where   membership' = Here   {-# INLINE membership' #-} -instance Find t z => Find t (_1 ': z) where-  membership' = There $ membership' @_ @t @z+instance Member t z => Member t (_1 ': z) where+  membership' = There $ membership' @t @z   {-# INLINE membership' #-}  ------------------------------------------------------------------------------@@ -305,20 +282,14 @@ -- | Retrieve the last effect in a 'Union'. extract :: Union '[e] m a -> Weaving e m a extract (Union Here a)   = a-#if __GLASGOW_HASKELL__ < 808-extract (Union (There g) _) = case g of {}-#endif+extract (Union (There _) _) = error "Unsafe use of UnsafeMkElemOf" {-# INLINE extract #-}   ------------------------------------------------------------------------------ -- | An empty union contains nothing, so this function is uncallable. absurdU :: Union '[] m a -> b-#if __GLASGOW_HASKELL__ < 808-absurdU (Union pr _) = case pr of {}-#else-absurdU = \case {}-#endif+absurdU (Union _ _) = error "Unsafe use of UnsafeMkElemOf"   ------------------------------------------------------------------------------

@@ -16,36 +16,6 @@ -------------------------------------------------------------------------------- -- | -- >>> :{--- foo :: Sem r ()--- foo = put ()--- :}--- ...--- ... Ambiguous use of effect 'State'--- ...--- ... (Member (State ()) r) ...--- ...-ambiguousMonoState = ()-------------------------------------------------------------------------------------- |--- >>> :{--- foo :: Sem r ()--- foo = put 5--- :}--- ...--- ... Ambiguous use of effect 'State'--- ...--- ... (Member (State s0) r) ...--- ...--- ... 's0' directly...--- ...-ambiguousPolyState = ()-------------------------------------------------------------------------------------- |--- >>> :{ -- interpret @(Reader Bool) $ \case --   Ask -> undefined -- :}@@ -79,41 +49,6 @@ -------------------------------------------------------------------------------- -- | -- >>> :{--- let reinterpretScrub :: Sem (Output Int ': m) a -> Sem (State Bool ': Trace ': m) a---     reinterpretScrub = undefined---     foo :: Sem '[Output Int] ()---     foo = pure ()---     foo' = reinterpretScrub foo---     foo'' = runState True foo'---     foo''' = traceToIO foo''---  in runM foo'''--- :}--- ...--- ... Unhandled effect 'Embed IO'--- ...--- ... Expected... Sem '[Embed m] (Bool, ())--- ... Actual... Sem '[] (Bool, ())--- ...-runningTooManyEffects = ()-------------------------------------------------------------------------------------- |--- >>> :{--- foo :: Sem (State Int ': r) ()--- foo = put ()--- :}--- ...--- ... Ambiguous use of effect 'State'--- ...--- ... (Member (State ()) (State Int : r)) ...--- ...-ambiguousSendInConcreteR = ()-------------------------------------------------------------------------------------- |--- >>> :{ -- let foo :: Member Resource r => Sem r () --     foo = undefined --  in runM $ lowerResource foo@@ -124,31 +59,4 @@ -- ... Probable cause: ... is applied to too few arguments -- ... missingArgumentToRunResourceInIO = ()-------------------------------------------------------------------------------------- |--- >>> :{--- existsKV :: Member (State (Maybe Int)) r => Sem r Bool--- existsKV = isJust get--- :}--- ...--- ... Ambiguous use of effect 'State'--- ...------ NOTE: This is fixed by enabling the plugin!-missingFmap'PLUGIN = ()------------------------------------------------------------------------------------- |--- >>> :{--- foo :: Sem '[State Int, Embed IO] ()--- foo = output ()--- :}--- ...--- ... Unhandled effect 'Output ()'--- ...--- ... add an interpretation for 'Output ()'--- ...-missingEffectInStack'WRONG = ()