polysemy 0.2.2.0 → 0.3.0.0

raw patch · 8 files changed

+221/−156 lines, 8 filesdep −randomPVP ok

version bump matches the API change (PVP)

Dependencies removed: random

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• polysemy.cabal +3/−7
• src/Polysemy.hs +0/−37
• src/Polysemy/Internal/TH/Effect.hs +57/−39
• src/Polysemy/Internal/TH/Performance.hs +0/−15
• src/Polysemy/Internal/Tactics.hs +1/−1
• src/Polysemy/Random.hs +0/−57
• test/ThEffectSpec.hs +153/−0

@@ -1,5 +1,12 @@ # Changelog for polysemy +## 0.3.0.0 (2019-06-01)++- Removed all deprecated names+- Moved `Random` effect to `polysemy-zoo`+- `makeSem` can now be used to create term-level operators (thanks to+    @TheMatten)+ ## 0.2.2.0 (2019-05-30)  - Added `getInspectorT` to the `Tactical` functions, which allows polysemy code

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: c0c48158ef37719851ad6b2bef99ba3236628e92c385792bac924109605febe9+-- hash: 9ee186fecebe41f0688aa073f56c51a08f7f3881a86af44a4d91a6cb8b4d6005  name:           polysemy-version:        0.2.2.0+version:        0.3.0.0 synopsis:       Higher-order, low-boilerplate, zero-cost free monads. description:    Please see the README on GitHub at <https://github.com/isovector/polysemy#readme> category:       Language@@ -52,12 +52,10 @@       Polysemy.Internal.NonDet       Polysemy.Internal.Tactics       Polysemy.Internal.TH.Effect-      Polysemy.Internal.TH.Performance       Polysemy.Internal.Union       Polysemy.IO       Polysemy.NonDet       Polysemy.Output-      Polysemy.Random       Polysemy.Reader       Polysemy.Resource       Polysemy.State@@ -73,7 +71,6 @@       base >=4.7 && <5     , containers >=0.6 && <=0.7     , mtl >=2.2.2 && <3-    , random >=1.1 && <1.2     , syb >=0.7 && <=0.8     , template-haskell >=2.14.0.0 && <2.15     , th-abstraction >=0.3 && <=0.4@@ -95,6 +92,7 @@       HigherOrderSpec       InspectorSpec       OutputSpec+      ThEffectSpec       Paths_polysemy   hs-source-dirs:       test@@ -107,7 +105,6 @@     , inspection-testing >=0.4.1.1 && <0.5     , mtl >=2.2.2 && <3     , polysemy-    , random >=1.1 && <1.2     , syb >=0.7 && <=0.8     , template-haskell >=2.14.0.0 && <2.15     , th-abstraction >=0.3 && <=0.4@@ -131,7 +128,6 @@     , freer-simple     , mtl     , polysemy-    , random >=1.1 && <1.2     , syb >=0.7 && <=0.8     , template-haskell >=2.14.0.0 && <2.15     , th-abstraction >=0.3 && <=0.4

@@ -109,47 +109,10 @@   , bindT   , getInspectorT   , Inspector (..)--  -- * Deprecated Names-  -- | The following exports are deprecated, and are exposed only for-  -- backwards compatability reasons. They will be removed in the next major-  -- release.-  , Semantic-  , runSemantic-  , makeSemantic-  , makeSemantic_-  , inlineRecursiveCalls   ) where  import Polysemy.Internal import Polysemy.Internal.Combinators import Polysemy.Internal.TH.Effect-import Polysemy.Internal.TH.Performance import Polysemy.Internal.Tactics---- Imported just for the deprecated names.-import Polysemy.Internal.Union-import Language.Haskell.TH------------------------------------------------------------------------------------- Deprecated names-type Semantic = Sem-{-# DEPRECATED Semantic "Use 'Sem' instead" #-}--runSemantic :: ∀ m r a-  . Monad m-  => Semantic r a -> (∀ x. Union r (Sem r) x -> m x)-  -> m a-runSemantic = runSem-{-# DEPRECATED runSemantic "Use 'runSem' instead" #-}---makeSemantic :: Name -> Q [Dec]-makeSemantic = makeSem-{-# DEPRECATED makeSemantic "Use 'makeSem' instead" #-}--makeSemantic_ :: Name -> Q [Dec]-makeSemantic_ = makeSem_-{-# DEPRECATED makeSemantic_ "Use 'makeSem_' instead" #-}- 

@@ -36,15 +36,15 @@  import Control.Monad import Data.Bifunctor-import Data.Char                      (toLower)+import Data.Char (toLower) import Data.Either-import Data.Generics+import Data.Generics hiding (Fixity) import Data.List import Data.Tuple import Language.Haskell.TH import Language.Haskell.TH.PprLib import Language.Haskell.TH.Datatype-import Polysemy.Internal              (send, Member, Sem)+import Polysemy.Internal (send, Member, Sem) import Polysemy.Internal.CustomErrors (DefiningModule)  import qualified Data.Map.Strict as M@@ -55,15 +55,18 @@ -- | If @T@ is a GADT representing an effect algebra, as described in the -- module documentation for "Polysemy", @$('makeSem' ''T)@ automatically -- generates a smart constructor for every data constructor of @T@. This also--- works for data family instances.+-- works for data family instances. Names of smart constructors are created by+-- changing first letter to lowercase or removing prefix @:@ in case of+-- operators. Fixity declaration is preserved for both normal names and+-- operators. -- -- @since 0.1.2.0 makeSem :: Name -> Q [Dec] makeSem = genFreer True --- | Like 'makeSem', but does not provide type signatures. This can be used--- to attach Haddock comments to individual arguments for each generated--- function.+-- | Like 'makeSem', but does not provide type signatures and fixities. This+-- can be used to attach Haddock comments to individual arguments for each+-- generated function. -- -- @ -- data Output o m a where@@ -140,18 +143,20 @@                          ]   decs       <- traverse (genDec should_mk_sigs) cl_infos -  let sigs = [ genSig <$> cl_infos | should_mk_sigs ]+  let sigs = if should_mk_sigs then genSig <$> cl_infos else []    return $ join $ def_mod_fi : sigs ++ decs  ------------------------------------------------------------------------------ -- | Generates signature for lifting function and type arguments to apply in -- its body on effect's data constructor.-genSig :: ConLiftInfo -> Dec+genSig :: ConLiftInfo -> [Dec] genSig cli-  = SigD (cliFunName cli) $ quantifyType-  $ ForallT [] (member_cxt : cliFunCxt cli)-  $ foldArrows $ cliFunArgs cli ++ [sem `AppT` cliResType cli]+  =  maybe [] (pure . flip InfixD (cliFunName cli)) (cliFunFixity cli)+  ++ [ SigD (cliFunName cli) $ quantifyType+       $ ForallT [] (member_cxt : cliFunCxt cli)+       $ foldArrows $ cliFunArgs cli ++ [sem `AppT` cliResType cli]+     ]   where     member_cxt = classPred ''Member [eff, VarT $ cliUnionName cli]     eff        = foldl' AppT (ConT $ cliEffName cli) $ cliEffArgs cli@@ -181,17 +186,27 @@         ]     ] --------------------------------------------------------------------------------+------------------------------------------------------------------------------ -- | Info about constructor being lifted; use 'mkCLInfo' to create one. data ConLiftInfo = CLInfo-  { cliEffName   :: Name    -- ^ name of effect's type constructor-  , cliEffArgs   :: [Type]  -- ^ effect specific type arguments-  , cliResType   :: Type    -- ^ result type specific to action-  , cliConName   :: Name    -- ^ name of action constructor-  , cliFunName   :: Name    -- ^ name of final function-  , cliFunArgs   :: [Type]  -- ^ final function arguments-  , cliFunCxt    :: Cxt     -- ^ constraints of final function-  , cliUnionName :: Name    -- ^ name of type variable parameterizing 'Sem'+  { -- | Name of effect's type constructor+    cliEffName   :: Name+    -- | Effect-specific type arguments+  , cliEffArgs   :: [Type]+    -- | Result type specific to action+  , cliResType   :: Type+    -- | Name of action constructor+  , cliConName   :: Name+    -- | Name of final function+  , cliFunName   :: Name+    -- | Fixity of function used as an operator+  , cliFunFixity :: Maybe Fixity+    -- | Final function arguments+  , cliFunArgs   :: [Type]+    -- | Constraints of final function+  , cliFunCxt    :: Cxt+    -- | Name of type variable parameterizing 'Sem'+  , cliUnionName :: Name   } deriving Show  ------------------------------------------------------------------------------@@ -204,7 +219,7 @@   (raw_cli_eff_args, [m_arg, raw_cli_res_arg]) <-     case splitAtEnd 2 $ datatypeInstTypes dti of       r@(_, [_, _]) -> return r-      _             -> missingEffTArgs cliEffName+      _             -> missingEffArgs cliEffName    m_name <-     case tVarName m_arg of@@ -212,6 +227,7 @@       Nothing       -> mArgNotVar cliEffName m_arg    cliUnionName <- newName "r"+  cliFunFixity <- reifyFixity $ constructorName ci    let normalizeType         = replaceMArg m_name cliUnionName                             . simplifyKinds@@ -229,8 +245,7 @@       cliEffArgs            = normalizeType <$> raw_cli_eff_args       cliResType            = normalizeType     raw_cli_res_arg       cliConName            = constructorName ci-      cliFunName            = mkName $ mapHead toLower $ nameBase-                            $ constructorName ci+      cliFunName            = liftFunNameFromCon cliConName       cliFunArgs            = normalizeType <$> constructorFields ci    return CLInfo{..}@@ -243,8 +258,8 @@   $  text "Monad argument ‘" <> ppr mArg <> text "’ in effect ‘"   <> ppr name <> text "’ is not a type variable" -missingEffTArgs :: Name -> Q a-missingEffTArgs name = fail $ show+missingEffArgs :: Name -> Q a+missingEffArgs name = fail $ show   $   text "Effect ‘" <> ppr name       <> text "’ has not enough type arguments"   $+$ nest 4@@ -256,7 +271,7 @@           )       )   where-    base = mkName $ nameBase $ name+    base = capturableBase name     args = PlainTV . mkName <$> ["m", "a"]  checkExtensions :: [Extension] -> Q ()@@ -266,7 +281,7 @@         (\(ext, _) -> fail $ show           $ char '‘' <> text (show ext) <> char '’'             <+> text "extension needs to be enabled\-                     \for smart constructors to work")+                     \ for smart constructors to work")         (find (not . snd) states)  ------------------------------------------------------------------------------@@ -282,6 +297,11 @@   t -> t  ------------------------------------------------------------------------------+-- | Constructs capturable name from base of input name.+capturableBase :: Name -> Name+capturableBase = mkName . nameBase++------------------------------------------------------------------------------ -- | Replaces use of @m@ in type with @Sem r@. replaceMArg :: TypeSubstitution t => Name -> Name -> t -> t replaceMArg m r = applySubstitution $ M.singleton m $ ConT ''Sem `AppT` VarT r@@ -309,6 +329,15 @@   _                -> Right p  ------------------------------------------------------------------------------+-- | Creates name of lifting function from action name.+liftFunNameFromCon :: Name -> Name+liftFunNameFromCon n = mkName $ case nameBase n of+                         ':':cs -> cs+                         c  :cs -> toLower c : cs+                         ""     -> error+                           "liftFunNameFromCon: empty constructor name"++------------------------------------------------------------------------------ -- | Folds a list of 'Type's into a right-associative arrow 'Type'. foldArrows :: [Type] -> Type foldArrows = foldr1 $ AppT . AppT ArrowT@@ -325,17 +354,6 @@   _             -> Nothing  --------------------------------------------------------------------------------- | Constructs capturable name from base of input name.-capturableBase :: Name -> Name-capturableBase = mkName . nameBase-------------------------------------------------------------------------------- -- | 'splitAt' counting from the end. splitAtEnd :: Int -> [a] -> ([a], [a]) splitAtEnd n = swap . join bimap reverse . splitAt n . reverse----------------------------------------------------------------------------------- | Applies function to head of list, if there is one.-mapHead :: (a -> a) -> [a] -> [a]-mapHead _ []     = []-mapHead f (x:xs) = f x : xs

@@ -1,15 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}--module Polysemy.Internal.TH.Performance-  ( inlineRecursiveCalls-  ) where--import Language.Haskell.TH--{-# DEPRECATED inlineRecursiveCalls-      "Enabling polysemy-plugin now automatically inlines recursive calls"-      #-}--inlineRecursiveCalls :: Q [Dec] -> Q [Dec]-inlineRecursiveCalls = id-

@@ -121,7 +121,7 @@ -- | A container for 'inspect'. See the documentation for 'getInspectorT'. newtype Inspector f = Inspector   { inspect :: forall x. f x -> Maybe x-    -- ^ See the documnetation for 'getInspectorT'.+    -- ^ See the documentation for 'getInspectorT'.   }  

@@ -1,57 +0,0 @@-{-# LANGUAGE BlockArguments  #-}-{-# LANGUAGE TemplateHaskell #-}--module Polysemy.Random-  ( -- * Effect-    Random (..)--    -- * Actions-  , random-  , randomR--    -- * Interpretations-  , runRandom-  , runRandomIO-  ) where--import           Polysemy-import           Polysemy.State-import qualified System.Random as R----------------------------------------------------------------------------------- | An effect capable of providing 'R.Random' values.-data Random m a where-  Random :: R.Random x => Random m x-  RandomR :: R.Random x => (x, x) -> Random m x--makeSem ''Random------------------------------------------------------------------------------------ | Run a 'Random' effect with an explicit 'R.RandomGen'.-runRandom-    :: forall q r a-     . R.RandomGen q-    => q-    -> Sem (Random ': r) a-    -> Sem r (q, a)-runRandom q = runState q . reinterpret \case-  Random -> do-    ~(a, q') <- gets @q R.random-    put q'-    pure a-  RandomR r -> do-    ~(a, q') <- gets @q $ R.randomR r-    put q'-    pure a-{-# INLINE runRandom #-}------------------------------------------------------------------------------------ | Run a 'Random' effect by using the 'IO' random generator.-runRandomIO :: Member (Lift IO) r => Sem (Random ': r) a -> Sem r a-runRandomIO m = do-  q <- sendM R.newStdGen-  snd <$> runRandom q m-{-# INLINE runRandomIO #-}-

@@ -0,0 +1,153 @@+{-# LANGUAGE TemplateHaskell, GADTs, DataKinds, AllowAmbiguousTypes #-}++module ThEffectSpec where++import Polysemy+import Test.Hspec+import GHC.TypeLits+import Data.Kind+import Language.Haskell.TH hiding (Type)++spec :: Spec+spec = it "should compile" True++-- Infix effects and actions -------------------------------------------------++data (:#) m a where+  (:#) :: a -> b -> m :# a++infixl 4 :#++makeSem ''(:#)++reifyFixity '(#) >>= \case+  Just (Fixity 4 InfixL) -> return []+  _                      -> fail "Wrong fixity of generated operator"++-- ADTs and ADT syntax -------------------------------------------------------++data SimpleADT m a = SimpleADTC1 Int | SimpleADTC2 String++makeSem ''SimpleADT++data GADTSyntax m a where+  GADTSyntaxC1 :: Int -> GADTSyntax m a+  GADTSyntaxC2 :: String -> GADTSyntax m a++makeSem ''GADTSyntax++data ADTSyntax1 m a = (a ~ Int) => ADTSyntax1C String++makeSem ''ADTSyntax1++data ADTSyntax2 m a+  = a ~ Int => ADTSyntax2C1 Int+  | a ~ String => ADTSyntax2C2 String++makeSem ''ADTSyntax2++data ADTSyntax3 m a = Show a => ADTSyntax3C a++makeSem ''ADTSyntax3++-- We don't care about named fields (except that we accept them as names from+-- effect in 'makeSem')+data Fields m a = FieldsC { fieldsCF1 :: Int, fieldsCF2 :: String }++makeSem ''Fields++-- Newtypes ------------------------------------------------------------------++newtype Newtype1 m a = Newtype1C Int++makeSem ''Newtype1++newtype Newtype2 m a where+  Newtype2C :: String -> Newtype2 m a++makeSem ''Newtype2++-- Data families -------------------------------------------------------------++data Instance = ADTI | GADTI | NTI++data family Family (s :: Instance) (m :: Type -> Type) a++data instance Family 'ADTI m a = ADTIC1 Int | ADTIC2 String++makeSem 'ADTIC1++data instance Family 'GADTI m a where+  GADTIC1 :: Int -> Family 'GADTI m Int+  GADTIC2 :: String -> Family 'GADTI m String++makeSem 'GADTIC1++newtype instance Family 'NTI m a = NTIC Int++makeSem 'NTIC++-- Phantom types -------------------------------------------------------------++data Phantom m a++makeSem ''Phantom++-- Complex action types ------------------------------------------------------++-- Inspired by:+-- github.com/lexi-lambda/freer-simple/blob/ec84ae4e23ccba1ae05368100da750c196bbbcbb/tests/Tests/TH.hs#L37+data Complex m a where+  Mono            :: Int -> Complex m Bool+  Poly            :: a -> Complex m a+  PolyIn          :: a -> Complex m Bool+  PolyOut         :: Int -> Complex m a+  Lots            :: a -> b -> c -> d -> e -> f -> Complex m ()+  Nested          :: Maybe b -> Complex m (Maybe a)+  MultiNested     :: (Maybe a, [b]) -> Complex m (Maybe a, [b])+  Existential     :: (forall e. e -> Maybe e) -> Complex m a+  LotsNested      :: Maybe a -> [b] -> (c, c) -> Complex m (a, b, c)+  Dict            :: Ord a => a -> Complex m a+  MultiDict       :: (Eq a, Ord b, Enum a, Num c)+                  => a -> b -> c -> Complex m ()+  IndexedMono     :: f 0 -> Complex m Int+  IndexedPoly     :: forall f (n :: Nat) m . f n -> Complex m (f (n + 1))+  IndexedPolyDict :: KnownNat n => f n -> Complex m Int++makeSem ''Complex++data HOEff m a where+  EffArgMono :: m () -> HOEff m ()+  EffArgPoly :: m a -> HOEff m a+  EffArgComb :: m a -> (m a -> m b) -> HOEff m b+  EffRank2   :: (forall x. m x -> m (Maybe x)) -> HOEff m a++makeSem ''HOEff++data ComplexEffArgs b c m a where+  EffMono     :: Int -> ComplexEffArgs Int String m Bool+  EffPoly1    :: a -> ComplexEffArgs a b m a+  EffPoly2    :: a -> ComplexEffArgs a (Maybe a) m Bool+  EffPolyFree :: String -> ComplexEffArgs a b m Int+  EffSame1    :: ComplexEffArgs a a m a+  EffSame2    :: ComplexEffArgs b b m a+  EffHO       :: m b -> ComplexEffArgs b Int m String++makeSem ''ComplexEffArgs++data HKEffArgs f g m a where+  HKRank2 :: (forall x . f x -> g x) -> HKEffArgs f g m a++makeSem ''HKEffArgs++-- 'makeSem' input names -----------------------------------------------------++data ByCon m a where+  ByConC :: Int -> ByCon m String++makeSem 'ByConC++data ByField m a where+  ByFieldC :: { byFieldCF :: Int } -> ByField m Int++makeSem 'byFieldCF