diff --git a/distributed-closure.cabal b/distributed-closure.cabal --- a/distributed-closure.cabal +++ b/distributed-closure.cabal @@ -1,5 +1,5 @@ name: distributed-closure -version: 0.2.1.0 +version: 0.3.0.0 synopsis: Serializable closures for distributed programming. description: See README. homepage: https://github.com/tweag/distributed-closure @@ -25,6 +25,7 @@ , binary >= 0.7.5 , bytestring >= 0.10 , constraints >= 0.4 + , syb >= 0.5 , template-haskell >= 2.10 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Control/Distributed/Closure.hs b/src/Control/Distributed/Closure.hs --- a/src/Control/Distributed/Closure.hs +++ b/src/Control/Distributed/Closure.hs @@ -1,6 +1,15 @@ --- | Serializable closures for distributed programming. +-- | Serializable closures for distributed programming. This package builds +-- a "remotable closure" abstraction on top of +-- . +-- See +-- +-- for a longer introduction. -{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Control.Distributed.Closure ( Serializable @@ -12,18 +21,29 @@ , cap , cmap -- * Closure dictionaries - -- $serializable-dicts + -- $static-dicts , Dict(..) + , Static(..) ) where import Control.Distributed.Closure.Internal import Data.Constraint (Dict(..)) --- $serializable-dicts +-- $static-dicts -- -- A 'Dict' reifies a constraint in the form of a first class value. The 'Dict' -- type is not serializable: how do you serialize the constraint that values of --- this type carry? However, for any constraint @c@, a value of type @'Closure' +-- this type carry? Whereas, for any constraint @c@, a value of type @'Closure' -- ('Dict' c)@ /can/ be serialized and sent over the wire, just like any --- 'Closure'. A /serializable dictionary/ for some constraint @c@ is a value of --- type @'Closure' ('Dict' c)@. +-- 'Closure'. A /static dictionary/ for some constraint @c@ is a value of type +-- @'Closure' ('Dict' c)@. + +-- | It's often useful to create a static dictionary on-the-fly given any +-- constraint. Morally, all type class constraints have associated static +-- dictionaries, since these are either global values or simple combinations +-- thereof. But GHC doesn't yet know how to invent a static dictionary on-demand +-- yet given any type class constraint, so we'll have to do it manually for the +-- time being. By defining instances of this type class manually, or via +-- 'Control.Distributed.Closure.TH.withStatic' if it becomes too tedious. +class c => Static c where + closureDict :: Closure (Dict c) diff --git a/src/Control/Distributed/Closure/TH.hs b/src/Control/Distributed/Closure/TH.hs --- a/src/Control/Distributed/Closure/TH.hs +++ b/src/Control/Distributed/Closure/TH.hs @@ -1,20 +1,36 @@ {-# LANGUAGE StaticPointers #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} -- | Utility Template Haskell macros. -module Control.Distributed.Closure.TH where +module Control.Distributed.Closure.TH + ( cstatic + , cstaticDict + , cdict + , cdictFrom + , withStatic + ) where import Control.Monad (replicateM) -import Control.Distributed.Closure.Internal -import Data.Constraint (Dict(..)) +import Control.Distributed.Closure +import Data.Generics (everything, mkQ) +import Data.List (nub) +import Data.Typeable (Typeable) import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH import Numeric.Natural -- | @$(cstatic 'foo)@ is an abbreviation for @closure (static foo)@. cstatic :: TH.Name -> TH.ExpQ cstatic f = [| closure (static $(TH.varE f)) |] +-- | @$(cstaticDict 'foo)@ is an abbreviation for @closure (static foo) `cap` +-- $cdict@, a common pattern for implicitly feeding the static dictionary when +-- which dictionary to choose is clear from context. +cstaticDict :: TH.Name -> TH.ExpQ +cstaticDict f = [| closure (static $(TH.varE f)) `cap` $cdict |] + -- | Abbreviation for @closure (static Dict)@. Example usage: -- -- @ @@ -28,7 +44,7 @@ -- | Create a static dictionary from the given dictionaries. Example usage: -- -- @ --- $cdictFrom 2 Dict Dict :: Closure (Static (Dict (Eq a, Show a))) +-- $cdictFrom 2 $cdict $cdict :: Closure (Static (Dict (Eq a, Show a))) -- @ cdictFrom :: Natural -> TH.ExpQ cdictFrom n0 = apply abstract [| closure (static $(staticFun n0)) |] n0 @@ -40,3 +56,61 @@ k names (foldl (\acc x -> [| $acc `cap` $(TH.varE x) |]) f names) abstract [] expr = expr abstract (nm:names) expr = [| \ $(TH.varP nm) -> $(abstract names expr) |] + +-- | Compute free variables of a type. +fvT :: TH.Type -> [TH.Name] +fvT = nub . everything (++) ([] `mkQ` (\ty -> [nm | TH.VarT nm <- [ty]])) + +caps :: [TH.ExpQ] -> TH.ExpQ +caps = foldl1 (\f x -> [| $f `cap` $x|]) + +-- XXX It turns out that GHC's newName doesn't produce really fresh names. Call +-- newName twice to define two new globals and you'll find they share the same +-- name. A workaround mentioned in https://ghc.haskell.org/trac/ghc/ticket/5398 +-- is this snippet of code... +mangleName :: TH.Name -> TH.Name +mangleName name@(TH.Name occ fl) = case fl of + TH.NameU u -> TH.Name (mangle_occ u) fl + _ -> name + where + mangle_occ :: Int -> TH.OccName + mangle_occ uniq = TH.mkOccName (TH.occString occ ++ "_" ++ show uniq) + +-- | Auto-generates the 'Static' instances corresponding to the given class +-- instances. Example: +-- +-- @ +-- data T a = T a +-- +-- withStatic [d| instance Show a => Show (T a) where ... |] +-- ======> +-- instance Show a => Show (T a) where ... +-- instance (Static (Show a), Typeable a) => Static (Show (T a)) where +-- closureDict = closure (static (Dict -> Dict)) `cap` closureDict +-- @ +withStatic :: TH.DecsQ -> TH.DecsQ +withStatic = (>>= go) + where + go [] = return [] + go (ins@(TH.InstanceD cxt hd _):decls) = do + let n = length cxt + dictsigs <- mapM (\c -> [t| Dict $(return c) |]) cxt + retsig <- [t| Dict $(return hd) |] + f <- mangleName <$> TH.newName "static_helper" + fbody <- foldr (\_ body -> [| \Dict -> $body |]) [| Dict |] cxt + let tyf = foldr (\a b -> TH.ArrowT `TH.AppT` a `TH.AppT` b) retsig dictsigs + sigf = TH.SigD f (TH.ForallT (map TH.PlainTV (fvT tyf)) [] tyf) + declf = TH.ValD (TH.VarP f) (TH.NormalB fbody) [] + methods <- (:[]) <$> + TH.valD + (TH.varP 'closureDict) + (TH.normalB (caps (cstatic f : replicate n [| closureDict |]))) + [] + staticcxt <- (++) <$> + mapM (\c -> [t| Static $(return c) |]) cxt <*> + mapM (\var -> [t| Typeable $(TH.varT var) |]) (fvT tyf) + statichd <- [t| Static $(return hd) |] + let staticins = TH.InstanceD staticcxt statichd methods + decls' <- go decls + return (ins : sigf : declf : staticins : decls') + go (decl:decls) = (decl:) <$> go decls diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StaticPointers #-} @@ -13,6 +14,14 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck + +data T a = T a + +-- Test that the result of this splice compiles. +withStatic [d| + instance Show a => Show (T a) where show = undefined + instance (Eq a, Show a) => Eq (T a) where (==) = undefined + |] instance Arbitrary (Closure Int) where arbitrary = cpure $cdict <$> elements [0..4]