├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CONTRIBUTING.md ├── ChangeLog ├── LICENSE ├── README.md ├── Setup.hs ├── distributed-static.cabal └── src └── Control └── Distributed └── Static.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Continuous Integration 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | continuous-integration: 7 | strategy: 8 | matrix: 9 | ghc-version: 10 | - "9.0.2" 11 | - "9.2.8" 12 | - "9.4.5" 13 | - "9.6.4" 14 | - "9.8.2" 15 | 16 | runs-on: ubuntu-latest 17 | 18 | steps: 19 | - uses: actions/checkout@v4 20 | 21 | - name: Install cabal/ghc 22 | uses: haskell-actions/setup@v2 23 | id: setup-haskell 24 | with: 25 | ghc-version: ${{ matrix.ghc-version }} 26 | cabal-version: '3.10.3.0' 27 | 28 | - name: Generate freeze file 29 | run: | 30 | cabal update 31 | cabal configure --disable-optimization 32 | cabal freeze 33 | # 'cabal freeze' will use the nearest index state which might not be exactly equal 34 | # to the index state specified in 'cabal.project' 35 | sed '/^index-state: /d' cabal.project.freeze > dependencies-versions 36 | 37 | - name: Cache cabal work 38 | uses: actions/cache@v4 39 | with: 40 | path: | 41 | dist-newstyle 42 | ${{ steps.setup-haskell.outputs.cabal-store }} 43 | # We are using the hash of 'cabal.project.local' so that different levels 44 | # of optimizations are cached separately 45 | key: ${{ runner.os }}-${{ hashFiles('dependencies-versions', 'cabal.project', 'cabal.project.local') }}-cabal-install 46 | 47 | - name: Build dependencies only 48 | run: | 49 | cabal build --only-dependencies 50 | 51 | - name: Build this package 52 | run: | 53 | cabal build -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md. 2 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2024-03-25 David Simmons-Duffin 0.3.10 2 | 3 | * Relax bytestring bounds to to build with ghc-9.8. 4 | 5 | 2019-05-12 Facundo Domínguez 0.3.9 6 | 7 | * Relax bounds to to build with ghc-8.6. 8 | 9 | 2017-08-28 Facundo Domínguez 0.3.8 10 | 11 | * Remove support for ghc-7.8 and lower 12 | * Fix build errors with ghc-8.2.1 13 | 14 | 2017-08-22 Facundo Domínguez 0.3.7 15 | 16 | * Make nominal the role of static 17 | 18 | 2017-08-22 Facundo Domínguez 0.3.6 19 | 20 | * Move upper bound of rank1dynamic to support ghc-8.2.1. 21 | * Remove dynamic type check in Static Binary instance. 22 | 23 | 2016-06-01 Facundo Domínguez 0.3.5.0 24 | 25 | * Add compatibility with ghc-8. 26 | 27 | 2016-02-18 Facundo Domínguez 0.3.4.0 28 | 29 | * Support static pointers. 30 | * Update .travis.yml to drop ghc-7.4 and test ghc-7.10. 31 | * Make Closure and Static strict data types. 32 | 33 | 2015-06-15 Facundo Domínguez 0.3.2.0 34 | 35 | * Loosen rank1dynamic bounds. 36 | * Add NFData instances. 37 | 38 | 2014-12-09 Tim Watson 0.3.1.0 39 | 40 | * Eq and Ord instances for Closure and Static 41 | 42 | 2014-05-30 Tim Watson 0.3.0.0 43 | 44 | * Bump binary dependency 45 | 46 | 2012-11-22 Edsko de Vries 0.2.1.1 47 | 48 | * Relax package bounds to allow for Binary 0.6 49 | 50 | 2012-10-03 Edsko de Vries 0.2.1 51 | 52 | * Add support for 'staticFlip' 53 | 54 | 2012-08-16 Edsko de Vries 0.2 55 | 56 | * Hide the 'Closure' constructor and export 'closure' instead so that we are 57 | free to change the internal representation 58 | 59 | 2012-08-10 Edsko de Vries 0.1 60 | 61 | * Initial release 62 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Edsko de Vries 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Edsko de Vries nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # distributed-static (archive) 2 | 3 | ## :warning: This package is now developed here: https://github.com/haskell-distributed/distributed-process :warning: 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /distributed-static.cabal: -------------------------------------------------------------------------------- 1 | Name: distributed-static 2 | Version: 0.3.10 3 | Synopsis: Compositional, type-safe, polymorphic static values and closures 4 | Description: /Towards Haskell in the Cloud/ (Epstein et al, Haskell 5 | Symposium 2011) introduces the concept of /static/ values: 6 | values that are known at compile time. In a distributed 7 | setting where all nodes are running the same executable, 8 | static values can be serialized simply by transmitting a 9 | code pointer to the value. This however requires special 10 | compiler support, which is not yet available in ghc. We 11 | can mimick the behaviour by keeping an explicit mapping 12 | ('RemoteTable') from labels to values (and making sure 13 | that all distributed nodes are using the same 14 | 'RemoteTable'). In this module we implement this mimickry 15 | and various extensions: type safety (including for 16 | polymorphic static values) and compositionality. 17 | Homepage: http://haskell-distributed.github.com 18 | License: BSD3 19 | License-File: LICENSE 20 | Author: Edsko de Vries 21 | Maintainer: Facundo Domínguez 22 | Bug-Reports: https://github.com/haskell-distributed/distributed-static/issues 23 | Copyright: Well-Typed LLP 24 | Category: Control 25 | Build-Type: Simple 26 | Cabal-Version: >=1.10 27 | extra-source-files: ChangeLog 28 | Tested-With: GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 29 | 30 | Source-Repository head 31 | Type: git 32 | Location: https://github.com/haskell-distributed/distributed-static 33 | 34 | Library 35 | Exposed-Modules: Control.Distributed.Static 36 | Build-Depends: base >= 4.8 && < 5, 37 | rank1dynamic >= 0.1 && < 0.5, 38 | containers >= 0.4 && < 0.8, 39 | bytestring >= 0.10 && < 0.13, 40 | binary >= 0.5 && < 0.9, 41 | deepseq >= 1.3.0.1 && < 1.6 42 | HS-Source-Dirs: src 43 | Default-Language: Haskell2010 44 | Default-Extensions: DeriveDataTypeable 45 | ScopedTypeVariables 46 | GHC-Options: -Wall 47 | -------------------------------------------------------------------------------- /src/Control/Distributed/Static.hs: -------------------------------------------------------------------------------- 1 | -- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011) 2 | -- introduces the concept of /static/ values: values that are known at compile 3 | -- time. In a distributed setting where all nodes are running the same 4 | -- executable, static values can be serialized simply by transmitting a code 5 | -- pointer to the value. This however requires special compiler support, which 6 | -- is not yet available in ghc. We can mimick the behaviour by keeping an 7 | -- explicit mapping ('RemoteTable') from labels to values (and making sure that 8 | -- all distributed nodes are using the same 'RemoteTable'). In this module 9 | -- we implement this mimickry and various extensions. 10 | -- 11 | -- [Compositionality] 12 | -- 13 | -- Static values as described in the paper are not compositional: there is no 14 | -- way to combine two static values and get a static value out of it. This 15 | -- makes sense when interpreting static strictly as /known at compile time/, 16 | -- but it severely limits expressiveness. However, the main motivation for 17 | -- 'static' is not that they are known at compile time but rather that 18 | -- /they provide a free/ 'Binary' /instance/. We therefore provide two basic 19 | -- constructors for 'Static' values: 20 | -- 21 | -- > staticLabel :: String -> Static a 22 | -- > staticApply :: Static (a -> b) -> Static a -> Static b 23 | -- 24 | -- The first constructor refers to a label in a 'RemoteTable'. The second 25 | -- allows to apply a static function to a static argument, and makes 'Static' 26 | -- compositional: once we have 'staticApply' we can implement numerous derived 27 | -- combinators on 'Static' values (we define a few in this module; see 28 | -- 'staticCompose', 'staticSplit', and 'staticConst'). 29 | -- 30 | -- [Closures] 31 | -- 32 | -- Closures in functional programming arise when we partially apply a function. 33 | -- A closure is a code pointer together with a runtime data structure that 34 | -- represents the value of the free variables of the function. A 'Closure' 35 | -- represents these closures explicitly so that they can be serialized: 36 | -- 37 | -- > data Closure a = Closure (Static (ByteString -> a)) ByteString 38 | -- 39 | -- See /Towards Haskell in the Cloud/ for the rationale behind representing 40 | -- the function closure environment in serialized ('ByteString') form. Any 41 | -- static value can trivially be turned into a 'Closure' ('staticClosure'). 42 | -- Moreover, since 'Static' is now compositional, we can also define derived 43 | -- operators on 'Closure' values ('closureApplyStatic', 'closureApply', 44 | -- 'closureCompose', 'closureSplit'). 45 | -- 46 | -- [Monomorphic example] 47 | -- 48 | -- Suppose we are working in the context of some distributed environment, with 49 | -- a monadic type 'Process' representing processes, 'NodeId' representing node 50 | -- addresses and 'ProcessId' representing process addresses. Suppose further 51 | -- that we have a primitive 52 | -- 53 | -- > sendInt :: ProcessId -> Int -> Process () 54 | -- 55 | -- We might want to define 56 | -- 57 | -- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) 58 | -- 59 | -- In order to do that, we need a static version of 'send', and a static 60 | -- decoder for 'ProcessId': 61 | -- 62 | -- > sendIntStatic :: Static (ProcessId -> Int -> Process ()) 63 | -- > sendIntStatic = staticLabel "$send" 64 | -- 65 | -- > decodeProcessIdStatic :: Static (ByteString -> Int) 66 | -- > decodeProcessIdStatic = staticLabel "$decodeProcessId" 67 | -- 68 | -- where of course we have to make sure to use an appropriate 'RemoteTable': 69 | -- 70 | -- > rtable :: RemoteTable 71 | -- > rtable = registerStatic "$send" (toDynamic sendInt) 72 | -- > . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> Int)) 73 | -- > $ initRemoteTable 74 | -- 75 | -- We can now define 'sendIntClosure': 76 | -- 77 | -- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) 78 | -- > sendIntClosure pid = closure decoder (encode pid) 79 | -- > where 80 | -- > decoder :: Static (ByteString -> Int -> Process ()) 81 | -- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic 82 | -- 83 | -- [Polymorphic example] 84 | -- 85 | -- Suppose we wanted to define a primitive 86 | -- 87 | -- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) 88 | -- 89 | -- which turns a process that computes an integer into a process that computes 90 | -- the integer and then sends it someplace else. 91 | -- 92 | -- We can define 93 | -- 94 | -- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b) 95 | -- > bindStatic = staticLabel "$bind" 96 | -- 97 | -- provided that we register this label: 98 | -- 99 | -- > rtable :: RemoteTable 100 | -- > rtable = ... 101 | -- > . registerStatic "$bind" ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2) 102 | -- > $ initRemoteTable 103 | -- 104 | -- (Note that we are using the special 'Data.Rank1Typeable.ANY1' and 105 | -- 'Data.Rank1Typeable.ANY2' types from "Data.Rank1Typeable" to represent this 106 | -- polymorphic value.) Once we have a static bind we can define 107 | -- 108 | -- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) 109 | -- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid 110 | -- 111 | -- [Dealing with qualified types] 112 | -- 113 | -- In the above we were careful to avoid qualified types. Suppose that we have 114 | -- instead 115 | -- 116 | -- > send :: Binary a => ProcessId -> a -> Process () 117 | -- 118 | -- If we now want to define 'sendClosure', analogous to 'sendIntClosure' above, 119 | -- we somehow need to include the 'Binary' instance in the closure -- after 120 | -- all, we can ship this closure someplace else, where it needs to accept an 121 | -- 'a', /then encode it/, and send it off. In order to do this, we need to turn 122 | -- the Binary instance into an explicit dictionary: 123 | -- 124 | -- > data BinaryDict a where 125 | -- > BinaryDict :: Binary a => BinaryDict a 126 | -- > 127 | -- > sendDict :: BinaryDict a -> ProcessId -> a -> Process () 128 | -- > sendDict BinaryDict = send 129 | -- 130 | -- Now 'sendDict' is a normal polymorphic value: 131 | -- 132 | -- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ()) 133 | -- > sendDictStatic = staticLabel "$sendDict" 134 | -- > 135 | -- > rtable :: RemoteTable 136 | -- > rtable = ... 137 | -- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ()) 138 | -- > $ initRemoteTable 139 | -- 140 | -- so that we can define 141 | -- 142 | -- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ()) 143 | -- > sendClosure dict pid = closure decoder (encode pid) 144 | -- > where 145 | -- > decoder :: Static (ByteString -> a -> Process ()) 146 | -- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic 147 | -- 148 | -- [Word of Caution] 149 | -- 150 | -- You should not /define/ functions on 'ANY' and co. For example, the following 151 | -- definition of 'rtable' is incorrect: 152 | -- 153 | -- > rtable :: RemoteTable 154 | -- > rtable = registerStatic "$sdictSendPort" sdictSendPort 155 | -- > $ initRemoteTable 156 | -- > where 157 | -- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY) 158 | -- > sdictSendPort SerializableDict = SerializableDict 159 | -- 160 | -- This definition of 'sdictSendPort' ignores its argument completely, and 161 | -- constructs a 'SerializableDict' for the /monomorphic/ type @SendPort ANY@, 162 | -- which isn't what you want. Instead, you should do 163 | -- 164 | -- > rtable :: RemoteTable 165 | -- > rtable = registerStatic "$sdictSendPort" (sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)) 166 | -- > $ initRemoteTable 167 | -- > where 168 | -- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a) 169 | -- > sdictSendPort SerializableDict = SerializableDict 170 | {-# LANGUAGE StaticPointers #-} 171 | {-# LANGUAGE RoleAnnotations #-} 172 | module Control.Distributed.Static 173 | ( -- * Static values 174 | Static 175 | , staticLabel 176 | , staticApply 177 | , staticPtr 178 | , staticApplyPtr 179 | -- * Derived static combinators 180 | , staticCompose 181 | , staticSplit 182 | , staticConst 183 | , staticFlip 184 | -- * Closures 185 | , Closure 186 | , closure 187 | -- * Derived closure combinators 188 | , staticClosure 189 | , closureApplyStatic 190 | , closureApply 191 | , closureCompose 192 | , closureSplit 193 | -- * Resolution 194 | , RemoteTable 195 | , initRemoteTable 196 | , registerStatic 197 | , unstatic 198 | , unclosure 199 | ) where 200 | 201 | import Data.Binary 202 | ( Binary(get, put) 203 | , Put 204 | , Get 205 | , putWord8 206 | , getWord8 207 | , encode 208 | , decode 209 | ) 210 | import Data.ByteString.Lazy (ByteString, empty) 211 | import Data.Map (Map) 212 | import qualified Data.Map as Map (lookup, empty, insert) 213 | import Control.Arrow as Arrow ((***), app) 214 | import Control.DeepSeq (NFData(rnf), force) 215 | import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply) 216 | import Data.Rank1Typeable 217 | ( Typeable 218 | , ANY1 219 | , ANY2 220 | , ANY3 221 | , ANY4 222 | , TypeRep 223 | , typeOf 224 | ) 225 | 226 | -- Imports necessary to support StaticPtr 227 | import qualified GHC.Exts as GHC (Any) 228 | import GHC.StaticPtr 229 | import GHC.Fingerprint.Type (Fingerprint(..)) 230 | import System.IO.Unsafe (unsafePerformIO) 231 | import Data.Rank1Dynamic (unsafeToDynamic) 232 | import Unsafe.Coerce (unsafeCoerce) 233 | 234 | -------------------------------------------------------------------------------- 235 | -- Introducing static values -- 236 | -------------------------------------------------------------------------------- 237 | 238 | -- | Static dynamic values 239 | -- 240 | -- In the new proposal for static, the SPT contains these 'TypeRep's. 241 | -- In the current implemnentation however they do not, so we need to carry 242 | -- them ourselves. This is the TypeRep of @a@, /NOT/ of @StaticPtr a@. 243 | data SDynamic = SDynamic TypeRep (StaticPtr GHC.Any) 244 | deriving (Typeable) 245 | 246 | instance Show SDynamic where 247 | show (SDynamic typ ptr) = 248 | let spi = staticPtrInfo ptr 249 | (line, col) = spInfoSrcLoc spi 250 | in concat [ "<>" 252 | ] 253 | 254 | instance Eq SDynamic where 255 | SDynamic _ ptr1 == SDynamic _ ptr2 = 256 | staticKey ptr1 == staticKey ptr2 257 | 258 | instance Ord SDynamic where 259 | SDynamic _ ptr1 `compare` SDynamic _ ptr2 = 260 | staticKey ptr1 `compare` staticKey ptr2 261 | 262 | data StaticLabel = 263 | StaticLabel String 264 | | StaticApply !StaticLabel !StaticLabel 265 | | StaticPtr SDynamic 266 | deriving (Eq, Ord, Typeable, Show) 267 | 268 | instance NFData StaticLabel where 269 | rnf (StaticLabel s) = rnf s 270 | rnf (StaticApply a b) = rnf a `seq` rnf b 271 | -- There are no NFData instances for TypeRep or for StaticPtr :/ 272 | rnf (StaticPtr (SDynamic _a _b)) = () 273 | 274 | -- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'. 275 | newtype Static a = Static StaticLabel 276 | deriving (Eq, Ord, Typeable, Show) 277 | 278 | -- Trying to 'coerce' static values will lead to unification errors 279 | type role Static nominal 280 | 281 | instance NFData (Static a) where 282 | rnf (Static s) = rnf s 283 | 284 | instance Binary (Static a) where 285 | put (Static label) = putStaticLabel label 286 | get = Static <$> getStaticLabel 287 | 288 | -- We don't want StaticLabel to be its own Binary instance 289 | putStaticLabel :: StaticLabel -> Put 290 | putStaticLabel (StaticLabel string) = 291 | putWord8 0 >> put string 292 | putStaticLabel (StaticApply label1 label2) = 293 | putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2 294 | putStaticLabel (StaticPtr (SDynamic typ ptr)) = 295 | let Fingerprint hi lo = staticKey ptr 296 | in putWord8 2 >> put typ >> put hi >> put lo 297 | 298 | getStaticLabel :: Get StaticLabel 299 | getStaticLabel = do 300 | header <- getWord8 301 | case header of 302 | 0 -> StaticLabel <$> get 303 | 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel 304 | 2 -> do typ <- get 305 | hi <- get 306 | lo <- get 307 | let key = Fingerprint hi lo 308 | case unsaferLookupStaticPtr key of 309 | Nothing -> fail "StaticLabel.get: invalid pointer" 310 | Just ptr -> return $ StaticPtr (SDynamic typ ptr) 311 | _ -> fail "StaticLabel.get: invalid" 312 | 313 | -- | We need to be able to lookup keys outside of the IO monad so that we 314 | -- can provide a 'Get' instance. 315 | unsaferLookupStaticPtr :: StaticKey -> Maybe (StaticPtr a) 316 | unsaferLookupStaticPtr = unsafePerformIO . unsafeLookupStaticPtr 317 | 318 | -- | Create a primitive static value. 319 | -- 320 | -- It is the responsibility of the client code to make sure the corresponding 321 | -- entry in the 'RemoteTable' has the appropriate type. 322 | staticLabel :: String -> Static a 323 | staticLabel = Static . StaticLabel . force 324 | 325 | -- | Apply two static values 326 | staticApply :: Static (a -> b) -> Static a -> Static b 327 | staticApply (Static f) (Static x) = Static (StaticApply f x) 328 | 329 | -- | Construct a static value from a static pointer 330 | -- 331 | -- Since 0.3.4.0. 332 | staticPtr :: forall a. Typeable a => StaticPtr a -> Static a 333 | staticPtr x = Static . StaticPtr 334 | $ SDynamic (typeOf (undefined :: a)) (unsafeCoerce x) 335 | 336 | -- | Apply a static pointer to a static value 337 | -- 338 | -- Since 0.3.4.0. 339 | staticApplyPtr :: (Typeable a, Typeable b) 340 | => StaticPtr (a -> b) -> Static a -> Static b 341 | staticApplyPtr = staticApply . staticPtr 342 | 343 | -------------------------------------------------------------------------------- 344 | -- Eliminating static values -- 345 | -------------------------------------------------------------------------------- 346 | 347 | -- | Runtime dictionary for 'unstatic' lookups 348 | newtype RemoteTable = RemoteTable (Map String Dynamic) 349 | 350 | -- | Initial remote table 351 | initRemoteTable :: RemoteTable 352 | initRemoteTable = 353 | registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3)) 354 | . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1)) 355 | . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4))) 356 | . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2)) 357 | . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString))) 358 | . registerStatic "$flip" (toDynamic (flip :: (ANY1 -> ANY2 -> ANY3) -> ANY2 -> ANY1 -> ANY3)) 359 | $ RemoteTable Map.empty 360 | 361 | -- | Register a static label 362 | registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable 363 | registerStatic label dyn (RemoteTable rtable) 364 | = RemoteTable (Map.insert label dyn rtable) 365 | 366 | -- Pseudo-type: RemoteTable -> Static a -> a 367 | resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic 368 | resolveStaticLabel (RemoteTable rtable) (StaticLabel label) = 369 | case Map.lookup label rtable of 370 | Nothing -> Left $ "Invalid static label '" ++ label ++ "'" 371 | Just d -> Right d 372 | resolveStaticLabel rtable (StaticApply label1 label2) = do 373 | f <- resolveStaticLabel rtable label1 374 | x <- resolveStaticLabel rtable label2 375 | f `dynApply` x 376 | resolveStaticLabel _ (StaticPtr (SDynamic typ ptr)) = 377 | return $ unsafeToDynamic typ (deRefStaticPtr ptr) 378 | 379 | -- | Resolve a static value 380 | unstatic :: Typeable a => RemoteTable -> Static a -> Either String a 381 | unstatic rtable (Static label) = do 382 | dyn <- resolveStaticLabel rtable label 383 | fromDynamic dyn 384 | 385 | -------------------------------------------------------------------------------- 386 | -- Closures -- 387 | -------------------------------------------------------------------------------- 388 | 389 | -- | A closure is a static value and an encoded environment 390 | data Closure a = Closure !(Static (ByteString -> a)) !ByteString 391 | deriving (Eq, Ord, Typeable, Show) 392 | 393 | instance Binary (Closure a) where 394 | put (Closure st env) = put st >> put env 395 | get = Closure <$> get <*> get 396 | 397 | instance NFData (Closure a) where rnf (Closure f b) = rnf f `seq` rnf b 398 | 399 | closure :: Static (ByteString -> a) -- ^ Decoder 400 | -> ByteString -- ^ Encoded closure environment 401 | -> Closure a 402 | closure = Closure 403 | 404 | -- | Resolve a closure 405 | unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a 406 | unclosure rtable (Closure dec env) = do 407 | f <- unstatic rtable dec 408 | return (f env) 409 | 410 | -- | Convert a static value into a closure. 411 | staticClosure :: Static a -> Closure a 412 | staticClosure dec = closure (staticConst dec) empty 413 | 414 | -------------------------------------------------------------------------------- 415 | -- Predefined static values -- 416 | -------------------------------------------------------------------------------- 417 | 418 | -- | Static version of ('Prelude..') 419 | composeStatic :: Static ((b -> c) -> (a -> b) -> a -> c) 420 | composeStatic = staticLabel "$compose" 421 | 422 | -- | Static version of 'const' 423 | constStatic :: Static (a -> b -> a) 424 | constStatic = staticLabel "$const" 425 | 426 | -- | Static version of ('Arrow.***') 427 | splitStatic :: Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b')) 428 | splitStatic = staticLabel "$split" 429 | 430 | -- | Static version of 'Arrow.app' 431 | appStatic :: Static ((a -> b, a) -> b) 432 | appStatic = staticLabel "$app" 433 | 434 | -- | Static version of 'flip' 435 | flipStatic :: Static ((a -> b -> c) -> b -> a -> c) 436 | flipStatic = staticLabel "$flip" 437 | 438 | -------------------------------------------------------------------------------- 439 | -- Combinators on static values -- 440 | -------------------------------------------------------------------------------- 441 | 442 | -- | Static version of ('Prelude..') 443 | staticCompose :: Static (b -> c) -> Static (a -> b) -> Static (a -> c) 444 | staticCompose g f = composeStatic `staticApply` g `staticApply` f 445 | 446 | -- | Static version of ('Control.Arrow.***') 447 | staticSplit :: Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b')) 448 | staticSplit f g = splitStatic `staticApply` f `staticApply` g 449 | 450 | -- | Static version of 'Prelude.const' 451 | staticConst :: Static a -> Static (b -> a) 452 | staticConst x = constStatic `staticApply` x 453 | 454 | -- | Static version of 'Prelude.flip' 455 | staticFlip :: Static (a -> b -> c) -> Static (b -> a -> c) 456 | staticFlip f = flipStatic `staticApply` f 457 | 458 | -------------------------------------------------------------------------------- 459 | -- Combinators on Closures -- 460 | -------------------------------------------------------------------------------- 461 | 462 | -- | Apply a static function to a closure 463 | closureApplyStatic :: Static (a -> b) -> Closure a -> Closure b 464 | closureApplyStatic f (Closure decoder env) = 465 | closure (f `staticCompose` decoder) env 466 | 467 | decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString)) 468 | decodeEnvPairStatic = staticLabel "$decodeEnvPair" 469 | 470 | -- | Closure application 471 | closureApply :: forall a b . 472 | Closure (a -> b) -> Closure a -> Closure b 473 | closureApply (Closure fdec fenv) (Closure xdec xenv) = 474 | closure decoder (encode (fenv, xenv)) 475 | where 476 | decoder :: Static (ByteString -> b) 477 | decoder = appStatic 478 | `staticCompose` 479 | (fdec `staticSplit` xdec) 480 | `staticCompose` 481 | decodeEnvPairStatic 482 | 483 | -- | Closure composition 484 | closureCompose :: Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c) 485 | closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f 486 | 487 | -- | Closure version of ('Arrow.***') 488 | closureSplit :: Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b')) 489 | closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g 490 | --------------------------------------------------------------------------------