diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +## 0.0.1 + +* Supported GHC 9.0 / template-haskell-2.17 +* Added `runIODef` diff --git a/extensible-skeleton.cabal b/extensible-skeleton.cabal --- a/extensible-skeleton.cabal +++ b/extensible-skeleton.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: extensible-skeleton -version: 0 +version: 0.0.1 synopsis: Operational-based extensible effect library homepage: https://github.com/fumieval/extensible bug-reports: http://github.com/fumieval/extensible/issues @@ -9,13 +9,14 @@ license-file: LICENSE author: Fumiaki Kinoshita maintainer: Fumiaki Kinoshita -copyright: Copyright (c) 2019 Fumiaki Kinoshita +copyright: Copyright (c) 2021 Fumiaki Kinoshita category: Monads build-type: Simple stability: experimental -Tested-With: GHC == 8.4.4, GHC == 8.6.3 +Tested-With: GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1 extra-source-files: + CHANGELOG.md source-repository head type: git @@ -23,7 +24,9 @@ library build-depends: base >= 4.8 && <5 - , extensible >= 0.6.2, monad-skeleton, resourcet, membership, transformers, mtl + , extensible ^>= 0.8 + , monad-skeleton ^>= 0.1 + , resourcet, membership, transformers, mtl , exceptions, profunctors, template-haskell exposed-modules: Data.Extensible.Effect @@ -44,6 +47,6 @@ test-suite effects type: exitcode-stdio-1.0 main-is: effects.hs - build-depends: base, extensible + build-depends: base, extensible, extensible-skeleton hs-source-dirs: tests default-language: Haskell2010 diff --git a/src/Data/Extensible/Effect.hs b/src/Data/Extensible/Effect.hs --- a/src/Data/Extensible/Effect.hs +++ b/src/Data/Extensible/Effect.hs @@ -97,7 +97,6 @@ import Data.Extensible.Class import Data.Kind (Type) import Data.Functor.Identity -import Data.Profunctor.Unsafe -- Trustworthy since 7.8 import Data.Type.Equality import Type.Membership @@ -205,7 +204,7 @@ -- | Process an 'Eff' action using a record of 'Interpreter's. handleEff :: RecordOf (Interpreter m) xs -> Eff xs a -> MonadView m (Eff xs) a handleEff hs m = case debone m of - Instruction i t :>>= k -> views (pieceAt i) (runInterpreter .# getField) hs t :>>= k + Instruction i t :>>= k -> views (pieceAt i) (\(Field (Interpreter x)) -> x) hs t :>>= k Return a -> Return a -- | Anonymous representation of instructions. diff --git a/src/Data/Extensible/Effect/Default.hs b/src/Data/Extensible/Effect/Default.hs --- a/src/Data/Extensible/Effect/Default.hs +++ b/src/Data/Extensible/Effect/Default.hs @@ -15,7 +15,8 @@ -- 'MonadState', 'MonadError' instances ----------------------------------------------------------------------------- module Data.Extensible.Effect.Default ( - ReaderDef + runIODef + , ReaderDef , runReaderDef , StateDef , runStateDef @@ -48,6 +49,10 @@ instance (MonadIO m, Lookup xs "IO" m) => MonadIO (Eff xs) where liftIO = liftEff (Proxy :: Proxy "IO") . liftIO + +-- | 'retractEff' specialised for IO +runIODef :: Eff '["IO" ':> IO] a -> IO a +runIODef = retractEff #if MIN_VERSION_resourcet(1,2,0) instance (MonadResource m, Lookup xs "IO" m) => MonadResource (Eff xs) where diff --git a/src/Data/Extensible/Effect/TH.hs b/src/Data/Extensible/Effect/TH.hs --- a/src/Data/Extensible/Effect/TH.hs +++ b/src/Data/Extensible/Effect/TH.hs @@ -1,8 +1,10 @@ {-# LANGUAGE Trustworthy, TemplateHaskell, LambdaCase, ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} ------------------------------------------------------------------------ -- | -- Module : Data.Extensible.Effect.TH --- Copyright : (c) Fumiaki Kinoshita 2019 +-- Copyright : (c) Fumiaki Kinoshita 2021 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita @@ -62,13 +64,23 @@ -> do (cxts, dcs) <- fmap unzip $ traverse (con2Eff tparams) cs - let vars = map PlainTV $ nub $ concatMap (varsT . snd) cxts + let vars = map mkPlainTV $ nub $ concatMap (varsT . snd) cxts return $ [TySynD dataName vars (typeListT $ map snd cxts) | synSet] - ++ [ TySynD k (map PlainTV $ nub $ varsT t) t | synActions, (k, t) <- cxts] + ++ [ TySynD k (map mkPlainTV $ nub $ varsT t) t | synActions, (k, t) <- cxts] ++ concat dcs _ -> fail "mkEffects accepts GADT declaration" + where +#if MIN_VERSION_template_haskell(2,17,0) + mkPlainTV n = PlainTV n () +#else + mkPlainTV = PlainTV +#endif +#if MIN_VERSION_template_haskell(2,17,0) +con2Eff :: [TyVarBndr ()] -> Con -> Q ((Name, Type), [Dec]) +#else con2Eff :: [TyVarBndr] -> Con -> Q ((Name, Type), [Dec]) +#endif con2Eff _ (GadtC [name] st (AppT _ resultT)) = return $ effectFunD name (map snd st) resultT con2Eff tparams (ForallC _ eqs (NormalC name st)) @@ -78,12 +90,21 @@ runIO (print p) fail "Unsupported constructor" +#if MIN_VERSION_template_haskell(2,17,0) +fromMangledGADT :: [TyVarBndr ()] -> [Type] -> Name -> [(Strict, Type)] -> ((Name, Type), [Dec]) +#else fromMangledGADT :: [TyVarBndr] -> [Type] -> Name -> [(Strict, Type)] -> ((Name, Type), [Dec]) +#endif fromMangledGADT tyvars_ eqs con fieldTypes = effectFunD con argumentsT result where +#if MIN_VERSION_template_haskell(2,17,0) + getTV (PlainTV n _) = n + getTV (KindedTV n _ _) = n +#else getTV (PlainTV n) = n getTV (KindedTV n _) = n +#endif tyvars = map getTV tyvars_ @@ -123,7 +144,13 @@ fName = let (ch : rest) = nameBase key in mkName $ toLower ch : rest - typ = ForallT (map PlainTV $ varList : varsT resultT ++ concatMap varsT argumentsT) +#if MIN_VERSION_template_haskell(2,17,0) + mkPlainTV n = PlainTV n SpecifiedSpec +#else + mkPlainTV = PlainTV +#endif + + typ = ForallT (map mkPlainTV $ varList : varsT resultT ++ concatMap varsT argumentsT) [associateT nameT actionT varList] $ effectFunT varList argumentsT resultT diff --git a/tests/effects.hs b/tests/effects.hs --- a/tests/effects.hs +++ b/tests/effects.hs @@ -1,6 +1,11 @@ {-# LANGUAGE GADTs, DataKinds, FlexibleContexts, TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -ddump-splices #-} -import Data.Extensible +module Main where +import Control.Monad.IO.Class +import Data.Extensible.Effect +import Data.Extensible.Effect.TH +import Data.Extensible.Effect.Default decEffects [d| data Example a b x where @@ -19,4 +24,26 @@ Simple :: Simple () |] +handleSimple :: MonadIO (Eff xs) => Eff (Simple ': xs) a -> Eff xs a +handleSimple = peelAction0 (liftIO (putStrLn "hello")) + +handleConcrete :: MonadIO (Eff xs) => Eff (Concrete ': xs) a -> Eff xs a +handleConcrete = peelAction0 (\i -> liftIO (print i)) + +handlePolyArg :: (Show a, MonadIO (Eff xs)) => Eff (PolyArg a ': xs) a -> Eff xs a +handlePolyArg = peelAction0 (\i -> liftIO (print i)) + +handlePolyRes :: (Monoid a, MonadIO (Eff xs)) => Eff (PolyRes a ': xs) a -> Eff xs a +handlePolyRes = peelAction0 (pure mempty) + +handleUnboundArg :: (Monoid a, MonadIO (Eff xs)) => Eff (UnboundArg a ': xs) a -> Eff xs a +handleUnboundArg = peelAction0 (\_ -> pure ()) + +handleUnboundRes :: (Monoid a, MonadIO (Eff xs)) => Eff (UnboundRes a ': xs) a -> Eff xs a +handleUnboundRes = peelAction0 (pure mempty) + +ex_simple :: IO () +ex_simple = runIODef $ handleSimple simple + +main :: IO () main = return ()