packages feed

distributed-closure 0.2.1.0 → 0.3.0.0

raw patch · 4 files changed

+116/−12 lines, 4 filesdep +syb

Dependencies added: syb

Files

distributed-closure.cabal view
@@ -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
src/Control/Distributed/Closure.hs view
@@ -1,6 +1,15 @@--- | Serializable closures for distributed programming.+-- | Serializable closures for distributed programming. This package builds+-- a "remotable closure" abstraction on top of+-- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/static-pointers.html static pointers>.+-- See+-- <https://ocharles.org.uk/blog/guest-posts/2014-12-23-static-pointers.html this blog post>+-- 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)
src/Control/Distributed/Closure/TH.hs view
@@ -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
tests/test.hs view
@@ -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]