packages feed

static-closure (empty) → 0.1.0.0

raw patch · 8 files changed

+340/−0 lines, 8 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, constraints, containers, ghc-instances, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Clinton Mead (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Clinton Mead nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Control/Static/Closure.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StaticPointers #-}+{-|+This module contains a "closure" type, originally inspired by+'Control.Distributed.Closure.Internal.Closure', but modified significantly,+and also generalised in a number of ways.++There was some also unsafe casts in "Control.Distributed.Closure.Internal" that scared me,+which this package does not have.+-}+module Control.Static.Closure where++import Control.Static.Closure.IsClosure (IsClosure(closure, unclosure, cap))+import Control.Static.Closure.IsPureClosure (IsPureClosure(cpure, ClosureConstraint))+import Control.Static.Closure.HasClosureDict (HasClosureDict(getClosureDict))++import GHC.StaticPtr (IsStatic(fromStaticPtr), StaticPtr, deRefStaticPtr, staticKey, unsafeLookupStaticPtr)++import Data.Binary (Put, Get, Binary(put, get), encode, decode)+import Data.Word (Word8)++import Data.Constraint (Dict(Dict))++import qualified Data.ByteString.Lazy as BSL++import System.IO.Unsafe (unsafePerformIO)+import Data.Typeable (Typeable)++{-|+Somewhat inspired by 'Control.Distributed.Closure.Internal.Closure'+but modified. Whereas 'Control.Distributed.Closure.Internal.Closure' requires+the serialised type to be a lazy 'Data.ByteString.Lazy.ByteString', this closure+type allows the serialised type to be given as a parameter.+-}+data Closure t a where+  CPure :: !(Closure t (t -> a)) -> t -> a -> Closure t a+  CStaticPtr :: !(StaticPtr a) -> Closure t a+  CAp :: !(Closure t (a -> b)) -> !(Closure t a) -> Closure t b++instance IsClosure (Closure t) where+  closure = CStaticPtr+  unclosure = \case+    CPure _ _ x -> x+    CStaticPtr p -> deRefStaticPtr p+    CAp c1 c2 -> (unclosure c1) (unclosure c2)+  cap = CAp++decodeWithDict :: Dict (Binary a) -> BSL.ByteString -> a+decodeWithDict Dict = decode++instance IsPureClosure (Closure BSL.ByteString) where+  type ClosureConstraint (Closure BSL.ByteString) a = (Typeable a, HasClosureDict (Binary a))+  {-|+  Inspired by 'Control.Distributed.Closure.Internal.cpure'.+  -}+  cpure :: forall a. (Typeable a, HasClosureDict (Binary a)) => a -> Closure BSL.ByteString a+  cpure = go getClosureDict where+    go :: Closure BSL.ByteString (Dict (Binary a)) -> a -> Closure BSL.ByteString a+    go closureDict x = CPure f (encode x) x where+      f = static decodeWithDict `cap` closureDict++instance IsStatic (Closure t) where+  fromStaticPtr = CStaticPtr++instance Binary t => Binary (Closure t a) where+  put = putClosure+  get = getClosure++newtype Tag = Tag Word8 deriving Binary++pattern PureTag :: Tag+pattern PureTag = (Tag 0)++pattern StaticPtrTag :: Tag+pattern StaticPtrTag = Tag 1++pattern ApTag :: Tag+pattern ApTag = Tag 2++{-|+Inspired by 'Control.Distributed.Closure.Internal.putClosure'.+-}+putClosure :: Binary t => Closure t a -> Put+putClosure (CPure c bs _) = put PureTag >> put bs >> putClosure c+putClosure (CStaticPtr p) = put StaticPtrTag >> put (staticKey p)+putClosure (CAp c1 c2) = put ApTag >> putClosure c1 >> putClosure c2+{-|+Inspired by 'Control.Distributed.Closure.Internal.getDynClosure',+but I think simplified.+-}+getClosure :: Binary t => Get (Closure t a)+getClosure = get >>= \case+  PureTag -> do+    bs <- get+    c <- getClosure+    let x = (unclosure c) bs+    pure $ CPure c bs x+  StaticPtrTag -> get >>= \key -> case unsafePerformIO (unsafeLookupStaticPtr key) of+    Just sptr -> pure $ CStaticPtr sptr+    Nothing -> fail $ "Static pointer lookup failed: " ++ show key+  ApTag -> CAp <$> getClosure <*> getClosure+  _ -> fail "Binary.get(Closure): unrecognized tag."
+ src/Control/Static/Closure/HasClosureDict.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE StaticPointers #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Control.Static.Closure.HasClosureDict where++import Control.Static.Closure.IsClosure (IsClosure)+import Data.Constraint (Dict)+import Data.Binary (Binary)++import Control.Instances.GHC_Packages ()++import Control.Static.Closure.TH (mkAllInstances)++class c => HasClosureDict c where+  getClosureDict :: IsClosure t => t (Dict c)+{-+instance Static (Binary Int) where+  getClosureDict = static Dict++instance (Typeable a, Static (Binary a)) => Static (Binary [a]) where+  getClosureDict = (static (\Dict -> Dict)) `cap` (getClosureDict :: IsClosure t => t (Dict (Binary a)))+-}+--  getClosureDict = (static (\Dict -> Dict)) `cap` getClosureDict++--instance (Typeable a, Typeable b, Static (Binary a), Static (Binary b)) => Static (Binary (a,b)) where+--  getClosureDict = (static (\Dict Dict -> Dict)) `cap` (getClosureDict :: Closure t => t (Dict (Binary a))) `cap` (getClosureDict :: Closure t => t (Dict (Binary b)))++-- $(getAllInstances ''Binary)+$(mkAllInstances 'getClosureDict ''HasClosureDict ''Binary)
+ src/Control/Static/Closure/IsClosure.hs view
@@ -0,0 +1,10 @@+module Control.Static.Closure.IsClosure where++import GHC.StaticPtr (StaticPtr, IsStatic)++class IsStatic t => IsClosure t where+  closure :: StaticPtr a -> t a+  unclosure :: t a -> a+  cap :: t (a -> b) -> t a -> t b+  cmap :: StaticPtr (a -> b) -> t a -> t b+  cmap = cap . closure
+ src/Control/Static/Closure/IsPureClosure.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE TypeFamilies #-}++module Control.Static.Closure.IsPureClosure where++import Control.Static.Closure.IsClosure (IsClosure(unclosure))+import GHC.Exts (Constraint)++class IsClosure t => IsPureClosure t where+  type ClosureConstraint t a :: Constraint+  cpure :: ClosureConstraint t a => a -> t a+  cfmap :: ClosureConstraint t b => (a -> b) -> t a -> t b+  cfmap f = cpure . f . unclosure
+ src/Control/Static/Closure/TH.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE StaticPointers #-}++module Control.Static.Closure.TH where++import Data.Monoid (Endo(Endo, appEndo), (<>), mempty)+import Data.Typeable (Typeable)+import Control.Static.Closure.IsClosure (IsClosure(cap))+import Data.Constraint (Dict(Dict))++import Language.Haskell.TH (+  Name,+  Q,+  Info(ClassI),+  InstanceDec,+  Dec(InstanceD, FunD),+  Type(ForallT, AppT, SigT, VarT, ConT, InfixT, UInfixT, ParensT),+  Exp(VarE, ConE, InfixE, LamE, SigE, StaticE),+  Clause(Clause),+  Body(NormalB),+  Pat(ConP),+  reify,+  mkName+  )++getAllInstances :: Name -> Q [InstanceDec]+getAllInstances className = do+  result <- reify className+  case result of+    ClassI _ instanceDecs -> pure instanceDecs+    _ -> fail "getAllInstances: Not a class"++mkInstance :: Name -> Name -> InstanceDec -> InstanceDec+mkInstance getClosureDictName staticClassName instanceDec = case instanceDec of+  InstanceD maybeOverlap oldCxt oldType _ ->+    let+      dictTypeName = ''Dict+      dictType = ConT dictTypeName+      dictValueName = 'Dict+      dictValue = ConE dictValueName+      dictPat = ConP dictValueName []+      dummyTypeName = mkName "t"+      dummyType = VarT dummyTypeName+      closureClassName = ''IsClosure+      closureClass = ConT closureClassName+      capName = 'cap+      capValue = VarE capName+      getClosureDict = VarE getClosureDictName+      addClassF = AppT (ConT staticClassName)+      addTypeableF = AppT (ConT ''Typeable)+      newType = addClassF oldType+      newStaticCxt = addClassF <$> oldCxt+      newTypeableCxt = (addTypeableF . VarT) <$> ((oldType:oldCxt) >>= findAllTypeVars)+      newCxt = newTypeableCxt ++ newStaticCxt+      mkTypeSig cxt = ForallT [] [AppT closureClass dummyType] (AppT dummyType (AppT dictType cxt))+      mkArgExp cxt = SigE getClosureDict (mkTypeSig cxt)+      addArg x cxt = InfixE (Just x) capValue (Just (mkArgExp cxt))+      funcPart = case (length oldCxt) of+        0 -> dictValue+        n -> LamE (replicate n dictPat) dictValue+      body = NormalB (foldl addArg (StaticE funcPart) oldCxt)+      clause = Clause [] body []+      funClause = FunD getClosureDictName [clause]+    in+      InstanceD maybeOverlap newCxt newType [funClause]+  _ -> error "mkInstance: Not an instance"++mkAllInstances :: Name -> Name -> Name -> Q [InstanceDec]+mkAllInstances getClosureDictName staticClassName className = (fmap . fmap) (mkInstance getClosureDictName staticClassName) (getAllInstances className)++findAllTypeVars :: Type -> [Name]+findAllTypeVars x = appEndo (go x) [] where+  go = \case+    ForallT{} -> error "Don't know how do deal with Foralls in types"+    AppT t1 t2 -> go t1 <> go t2+    SigT t _ -> go t+    VarT name -> Endo (name:)+    InfixT t1 _ t2 -> go t1 <> go t2+    UInfixT t1 _ t2 -> go t1 <> go t2+    ParensT t -> go t+    _ -> mempty
+ static-closure.cabal view
@@ -0,0 +1,60 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: b35ca4aa455961836166ce7622895f36291cbf4351fc377238242deda4f68bd7++name:           static-closure+version:        0.1.0.0+synopsis:       Serialisable static pointers to functions+description:    A more generalised and expanded version of the ideas found in [distributed-closure](https://hackage.haskell.org/package/distributed-closure) in the following ways:-+                .+                1. This library allows for the core serialisable type to any type, although we currently only implement \"Binary\".+                .+                2. Template Haskell is used to implement dictionary instances for all instances of \"Binary\" in all packages shipped with GHC with the assistance of [ghc-instances](https://hackage.haskell.org/package/ghc-instances).+                .+                This library is very much a work in progress. It is largely untested except to check it compiles. Future tasks to do include:-+                .+                1. Writing some test cases to make sure this actually works.+                .+                2. Integrating with [freelude](https://hackage.haskell.org/package/freelude), the restricted \"pure\" function is perfect to define in \"freelude\".+                .+                3. Writing some more Template Haskell functions to allow easy integration with user defined types.+                .+                4. Linking this up with [acid-state](https://hackage.haskell.org/package/acid-state) in a somewhat sensible way.+category:       Control+homepage:       https://github.com/clintonmead/static-closure#readme+bug-reports:    https://github.com/clintonmead/static-closure/issues+author:         Clinton Mead+maintainer:     clintonmead@gmail.com+copyright:      Copyright: (c) 2018 Clinton Mead+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/clintonmead/static-closure++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , binary+    , bytestring+    , constraints+    , containers+    , ghc-instances+    , template-haskell+  exposed-modules:+      Control.Static.Closure+      Control.Static.Closure.HasClosureDict+      Control.Static.Closure.IsClosure+      Control.Static.Closure.IsPureClosure+      Control.Static.Closure.TH+  other-modules:+      Paths_static_closure+  default-language: Haskell2010